SWAGOLX.EXE (c) 1993 GDSOFT ALL RIGHTS RESERVED 00010 1 08-24-9413:17ALL SWAG SUPPORT TEAM High Precision BCD Math SWAG9408 ß╠æ┼ 363 ₧ unit AJCBCD;ππinterfaceππuses Objects, Strings;ππconstπ DigitSize = SizeOf(Byte);π bpw_Fixed = 0;π bpw_Variable = 1;π bpz_Blank = True;π bpz_NotBlank = False;π MaxBCDSize = 100;π st_Blanks25 = ' ';π st_Blanks = st_Blanks25π + st_Blanks25π + st_Blanks25π + st_Blanks25π + st_Blanks25π + st_Blanks25π + st_Blanks25π + st_Blanks25π + st_Blanks25π + st_Blanks25π + st_Blanks25;ππtypeπ PBCDArray = ^TBCDArray;π TBCDArray = array[1..MaxBCDSize] of byte;ππ TBCDSign = (BCDNegative, BCDPositive);ππ PBCD = ^TBCD;π TBCD = object(TObject)π BCDSize: Integer;π Sign: TBCDSign;π Value: PBCDArray;π Precision: Byte;π constructor InitBCD(AVal: PBCD);π constructor InitReal(AVal: Real; APrec: Byte; ASize: Integer);π constructor InitPChar(AVal: PChar; APrec: Byte; ASize: Integer);π destructor Done; virtual;π constructor Load(var S: TStream);π procedure Store(var S: TStream);π function GetValue: PBCDArray;π function GetSign: TBCDSign;π function GetPrecision: Byte;π function GetBCDSize: Integer;π procedure SetValueBCD(AVal: PBCD);π procedure SetValueReal(AVal: Real);π procedure SetValuePChar(AVal: PChar);π procedure SetSign(ASign: TBCDSign);π procedure SetPrecision(APrec: Byte);π procedure SetBCDSize(ASize: Integer);π procedure AddBCD(AVal: PBCD);π procedure AddReal(AVal: Real);π procedure AddPChar(AVal: PChar);π procedure SubtractBCD(AVal: PBCD);π procedure SubtractReal(AVal: Real);π procedure SubtractPChar(AVal: PChar);π procedure MultiplyByBCD(AVal: PBCD);π procedure MultiplyByReal(AVal: Real; APrec: Byte);π procedure MultiplyByPChar(AVal: PChar; APrec: Byte);π procedure DivideByBCD(AVal: PBCD);π procedure DivideByReal(AVal: Real; APrec: Byte);π procedure DivideByPChar(AVal: PChar; APrec: Byte);π procedure AbsoluteValue;π procedure Increment;π procedure Decrement;π procedure ShiftLeft(ShiftAmount: Byte);π procedure ShiftRight(ShiftAmount: Byte);π function BCD2Int: LongInt;π function BCD2Real: Real;π function PicStr(picture: string;π Width: Integer; BlankWhenZero: Boolean): String;π function StrPic(dest: PChar; picture: string;π Width: Integer; BlankWhenZero: Boolean;π Size: Integer): PChar;π function CompareBCD(AVal: PBCD): Integer;π function CompareReal(AVal: Real): Integer;π function ComparePChar(AVal: PChar): Integer;π end;ππconstππ RBCD: TStreamRec = (ObjType: 60000;π VmtLink: Ofs(TypeOf(TBCD)^);π Load: @TBCD.Load;π Store: @TBCD.Store);ππvarπ BCDZero: PBCD;ππimplementationππ{BCDAdd is a subroutine that adds the value in BCD2 to the value in }π{BCD1. It is a simple magnitude addition, as if the two numbers have }π{the same sign. BCDAdd makes the following assumptions: }π{ 1) the calling routine will manage the proper sign of the result }π{ of the addition. }π{ 2) the BCDSize of the two operands are equal }π{ 3) the Precision of the two operands are equal }πprocedure BCDAdd(BCD1, BCD2: PBCD);πvarπ i: integer;π Carry: Byte;πbeginπ Carry := 0;π for i := BCD1^.BCDSize downto 1 doπ beginπ BCD1^.Value^[i] := BCD1^.Value^[i] + BCD2^.Value^[i] + Carry;π if BCD1^.Value^[i] > 9 thenπ beginπ dec(BCD1^.Value^[i], 10);π Carry := 1;π endπ elseπ Carry := 0;π end;πend;ππ{BCDSubtraction is a subroutine that subtracts the value in BCD2 from }π{the value in BCD1. It is a simple magnitude subtraction, without }π{regard to the sign of the operands. BCDSubtract makes the following }π{assumptions: }π{ 1) the calling routine will manage the proper sign of the result }π{ of the subtraction. }π{ 2) the BCDSize of the two operands are equal }π{ 3) the Precision of the two operands are equal }π{ 4) the magnitude of the value in BCD2 is less than or equal to the }π{ magnitude of the value in BCD1 so that the routine can perform }π{ a simple byte by byte subtraction }πprocedure BCDSubtract(BCD1, BCD2: PBCD);πvarπ i: integer;π Borrow: Byte;πbeginπ Borrow := 0;π for i := BCD1^.GetBCDSize downto 1 doπ beginπ BCD1^.Value^[i] := BCD1^.Value^[i] + 10 - BCD2^.Value^[i] - Borrow;π if BCD1^.Value^[i] > 9 thenπ beginπ dec(BCD1^.Value^[i], 10);π Borrow := 0;π endπ elseπ Borrow := 1;π end;πend;ππconstructor TBCD.InitBCD(AVal: PBCD);πbeginπ inherited Init;π BCDSize := AVal^.GetBCDSize;π GetMem(Value, BCDSize*DigitSize);π Precision := AVal^.GetPrecision;π SetValueBCD(AVal);πend;ππconstructor TBCD.InitReal(AVal: Real; APrec: Byte; ASize: Integer);πbeginπ inherited Init;π if ASize > MaxBCDSize thenπ BCDSize := MaxBCDSizeπ elseπ BCDSize := ASize;π GetMem(Value, ASize*DigitSize);π Precision := APrec;π SetValueReal(AVal);πend;ππconstructor TBCD.InitPChar(AVal: PChar; APrec: Byte; ASize: Integer);πbeginπ inherited Init;π if ASize > MaxBCDSize thenπ BCDSize := MaxBCDSizeπ elseπ BCDSize := ASize;π GetMem(Value, ASize*DigitSize);π Precision := APrec;π SetValuePChar(AVal);πend;ππdestructor TBCD.Done;πbeginπ FreeMem(Value, BCDSize*DigitSize);π inherited Done;πend;ππconstructor TBCD.Load(var S: TStream);πbeginπ S.Read(BCDSize, SizeOf(BCDSize));π S.Read(Sign, SizeOf(Sign));π GetMem(Value, BCDSize*DigitSize);π S.Read(Value^, BCDSize*DigitSize);π S.Read(Precision, SizeOf(Precision));πend;ππprocedure TBCD.Store(var S: TStream);πbeginπ S.Write(BCDSize, SizeOf(BCDSize));π S.Write(Sign, SizeOf(Sign));π S.Write(Value^, BCDSize*DigitSize);π S.Write(Precision, SizeOf(Precision));πend;ππfunction TBCD.GetValue: PBCDArray;πvarπ WrkValue: PBCDArray;πbeginπ GetMem(WrkValue, BCDSize*DigitSize);π Move(Value^, WrkValue^, BCDSize*DigitSize);π GetValue := WrkValue;πend;ππfunction TBCD.GetSign: TBCDSign;πbeginπ GetSign := Sign;πend;ππfunction TBCD.GetPrecision: Byte;πbeginπ GetPrecision := Precision;πend;ππfunction TBCD.GetBCDSize: Integer;πbeginπ GetBCDSize := BCDSize;πend;ππprocedure TBCD.SetValueBCD(AVal: PBCD);πvarπ SaveSize: Integer;π SavePrecision: Byte;πbeginπ if AVal = nil then exit;ππ FreeMem(Value, BCDSize*DigitSize);ππ SaveSize := GetBCDSize;π SavePrecision := GetPrecision;ππ Value := AVal^.GetValue;π BCDSize := AVal^.GetBCDSize;π Precision := AVal^.GetPrecision;ππ if Precision > SavePrecision thenπ beginπ SetBCDSize(SaveSize);π SetPrecision(SavePrecision);π endπ elseπ beginπ SetPrecision(SavePrecision);π SetBCDSize(SaveSize);π end;ππ SetSign(AVal^.GetSign);πend;ππprocedure TBCD.SetSign(ASign: TBCDSign);πvarπ i: integer;πbeginπ Sign := BCDPositive;π if ASign = BCDPositive then exit;ππ {allow negative sign only if value is non-zero}π for i := GetBCDSize downto 1 doπ if Value^[i] <> 0 thenπ beginπ Sign := BCDNegative;π exit;π end;πend;ππprocedure TBCD.SetValueReal(AVal: Real);πvarπ i, BCDIndex: integer;π ValStr: String;πbeginπ FillChar(Value^, BCDSize*DigitSize, #0);ππ Str(abs(AVal):BCDSize:Precision, ValStr);π BCDIndex := BCDSize;π for i :=length(ValStr) downto 1 doπ if ValStr[i] in ['0'..'9'] thenπ beginπ Value^[BCDIndex] := ord(ValStr[i]) - ord('0');π dec(BCDIndex);π end;ππ if AVal < 0.0 thenπ SetSign(BCDNegative)π elseπ SetSign(BCDPositive);πend;ππprocedure TBCD.SetValuePChar(AVal: PChar);πvarπ i, BCDIndex: integer;π SavePrec: Byte;π SaveSign: TBCDSign;πbeginπ if AVal = nil then exit;ππ SaveSign := BCDPositive;π SavePrec := Precision;π Precision := 0;ππ FillChar(Value^, BCDSize*DigitSize, #0);ππ if StrLen(AVal) = 0 then exit;ππ BCDIndex := BCDSize;π for i := StrLen(AVal) downto 0 doπ case AVal[i] ofπ '0'..'9': beginπ Value^[BCDIndex] := ord(AVal[i]) - ord('0');π dec(BCDIndex);π end;π '(',')','-': beginπ SaveSign := BCDNegative;π end;π '.': beginπ Precision := BCDSize - BCDIndex;π end;π end; {case}ππ SetPrecision(SavePrec);π SetSign(SaveSign);πend;ππprocedure TBCD.SetPrecision(APrec: Byte);πbeginπ if APrec = Precision then exit;π if APrec < Precision thenπ ShiftRight(Precision - APrec)π elseπ ShiftLeft(APrec - Precision);π Precision := APrec;πend;ππprocedure TBCD.SetBCDSize(ASize: Integer);πvarπ SaveSize: Integer;π WrkVal: PBCDArray;πbeginπ if ASize = GetBCDSize then exit;ππ if ASize > MaxBCDSize then ASize := MaxBCDSize;ππ GetMem(WrkVal, ASize*DigitSize);π FillChar(WrkVal^, ASize*DigitSize, #0);ππ if ASize < GetBCDSize thenπ Move(Value^[(GetBCDSize-ASize)+1], WrkVal^, ASize*DigitSize)π else if ASize > GetBCDSize thenπ Move(Value^, WrkVal^[(ASize-GetBCDSize)+1], GetBCDSize);ππ FreeMem(Value, GetBCDSize*DigitSize);π Value := WrkVal;π BCDSize := ASize;πend;ππprocedure TBCD.AddBCD(AVal: PBCD);πvarπ WrkValue: PBCD;πbeginπ WrkValue := new(PBCD, InitBCD(AVal));π WrkValue^.SetPrecision(Precision);π WrkValue^.SetBCDSize(BCDSize);π if GetSign <> AVal^.GetSign thenπ if AVal^.GetSign = BCDNegative thenπ beginπ WrkValue^.AbsoluteValue;π BCDSubtract(@Self, WrkValue);π Dispose(WrkValue, Done);π exit;π endπ elseπ {AVal^.GetSign = BCDPositive}π beginπ AbsoluteValue;π BCDSubtract(WrkValue, @Self);π SetValueBCD(WrkValue);π Dispose(WrkValue, Done);π exit;π end;ππ BCDAdd(@Self, WrkValue);π Dispose(WrkValue, Done);πend;ππprocedure TBCD.AddReal(AVal: Real);πvarπ WrkValue: PBCD;πbeginπ WrkValue := new(PBCD, InitReal(AVal, GetPrecision, GetBCDSize));π AddBCD(WrkValue);π Dispose(WrkValue, Done);πend;ππprocedure TBCD.AddPChar(AVal: PChar);πvarπ WrkValue: PBCD;πbeginπ WrkValue := new(PBCD, InitPChar(AVal, GetPrecision, GetBCDSize));π AddBCD(WrkValue);π Dispose(WrkValue, Done);πend;ππprocedure TBCD.SubtractBCD(AVal: PBCD);πvarπ WrkValue: PBCD;π SaveSign: TBCDSign;πbeginπ if AVal = nil then exit;ππ WrkValue := new(PBCD, InitBCD(AVal));π WrkValue^.SetPrecision(GetPrecision);π WrkValue^.SetBCDSize(GetBCDSize);π if GetSign <> AVal^.GetSign thenπ beginπ WrkValue^.SetSign(Sign);π BCDAdd(@Self, WrkValue);π Dispose(WrkValue, Done);π exit;π end;ππ SaveSign := Sign;π AbsoluteValue;π WrkValue^.AbsoluteValue;π if CompareBCD(WrkValue) < 0 thenπ beginπ BCDSubtract(WrkValue, @Self);π SetValueBCD(WrkValue);π if SaveSign = BCDNegative thenπ SetSign(BCDPositive)π elseπ SetSign(BCDNegative);π endπ elseπ beginπ BCDSubtract(@Self, WrkValue);π SetSign(SaveSign);π end;ππ Dispose(WrkValue, Done);πend;ππprocedure TBCD.SubtractReal(AVal: Real);πvarπ WrkValue: PBCD;πbeginπ WrkValue := new(PBCD, InitReal(AVal, GetPrecision, GetBCDSize));π SubtractBCD(WrkValue);π Dispose(WrkValue, Done);πend;ππprocedure TBCD.SubtractPChar(AVal: PChar);πvarπ WrkValue: PBCD;πbeginπ WrkValue := new(PBCD, InitPChar(AVal, GetPrecision, GetBCDSize));π SubtractBCD(WrkValue);π Dispose(WrkValue, Done);πend;ππprocedure TBCD.MultiplyByBCD(AVal: PBCD);πvarπ NewSign: TBCDSign;π WrkValue: PBCD;π HighDigit, i, j: integer;π SavePrec: Byte;πbeginπ if AVal = nil then exit;ππ if GetSign = AVal^.GetSign thenπ NewSign := BCDPositiveπ elseπ NewSign := BCDNegative;π AbsoluteValue;ππ SavePrec := Precision;π WrkValue := new(PBCD, InitReal(0, 0, GetBCDSize + AVal^.GetBCDSize));π Precision := 0;π i := 1;π while (i < AVal^.GetBCDSize) and (AVal^.Value^[i] = 0) doπ inc(i);π HighDigit := i;ππ for i := AVal^.GetBCDSize downto HighDigit doπ beginπ if AVal^.Value^[i] <> 0 thenπ for j := 1 to AVal^.Value^[i] doπ WrkValue^.AddBCD(@Self);π ShiftLeft(1);π end;ππ WrkValue^.Precision := SavePrec + AVal^.GetPrecision;π WrkValue^.SetPrecision(SavePrec);π Precision := SavePrec;π SetValueBCD(WrkValue);π SetSign(NewSign);πend;ππprocedure TBCD.MultiplyByReal(AVal: Real; APrec: Byte);πvarπ WrkVal: PBCD;πbeginπ WrkVal := new(PBCD, InitReal(AVal, APrec, GetBCDSize));π MultiplyByBCD(WrkVal);π Dispose(WrkVal, Done);πend;ππprocedure TBCD.MultiplyByPChar(AVal: PChar; APrec: Byte);πvarπ WrkVal: PBCD;πbeginπ WrkVal := new(PBCD, InitPChar(AVal, APrec, GetBCDSize));π MultiplyByBCD(WrkVal);π Dispose(WrkVal, Done);πend;ππprocedure TBCD.DivideByBCD(AVal: PBCD);πvarπ NewSign: TBCDSign;π WrkVal, WrkDiv, WrkQuo: PBCD;π HighDigit, i, j, IterationCount: integer;π TempPrec, QuotientPrec: Byte;πbeginπ if AVal = nil then exit;ππ if AVal^.CompareReal(0.0) = 0 then exit; {avoid zero divide}ππ if GetSign = AVal^.GetSign thenπ NewSign := BCDPositiveπ elseπ NewSign := BCDNegative;ππ WrkVal := new(PBCD, InitBCD(@Self));π WrkVal^.AbsoluteValue;ππ WrkQuo := new(PBCD, InitReal(0, 0, GetBCDSize));ππ i := 1;π while (i < WrkVal^.GetBCDSize) and (WrkVal^.Value^[i] = 0) doπ inc(i);π HighDigit := i;π WrkVal^.SetPrecision(WrkVal^.GetPrecision+(HighDigit-1));π TempPrec := WrkVal^.GetPrecision;π WrkVal^.Precision := 0;ππ WrkDiv := new(PBCD, InitBCD(AVal));π WrkDiv^.AbsoluteValue;π i := 1;π while (i < WrkDiv^.GetBCDSize) and (WrkDiv^.Value^[i] = 0) doπ inc(i);π HighDigit := i;π WrkDiv^.ShiftLeft(HighDigit - 1);π WrkDiv^.Precision := 0;ππ QuotientPrec := TempPrec - AVal^.GetPrecision;π IterationCount := WrkVal^.GetBCDSize - QuotientPrec + GetPrecision;ππ for i := 1 to IterationCount doπ beginπ while CompareBCD(WrkDiv) > 0 doπ beginπ WrkVal^.SubtractBCD(WrkDiv);π inc(WrkQuo^.Value^[WrkQuo^.GetBCDSize]);π end;π WrkDiv^.ShiftRight(1);π WrkQuo^.ShiftLeft(1);π end;ππ WrkQuo^.Precision := QuotientPrec;π SetValueBCD(WrkQuo);π SetSign(NewSign);ππ Dispose(WrkVal, Done);π Dispose(WrkQuo, Done);π Dispose(WrkDiv, Done);πend;ππprocedure TBCD.DivideByReal(AVal: Real; APrec: Byte);πvarπ WrkVal: PBCD;πbeginπ WrkVal := new(PBCD, InitReal(AVal, APrec, GetBCDSize));π DivideByBCD(WrkVal);π Dispose(WrkVal, Done);πend;ππprocedure TBCD.DivideByPChar(AVal: PChar; APrec: Byte);πvarπ WrkVal: PBCD;πbeginπ WrkVal := new(PBCD, InitPChar(AVal, APrec, GetBCDSize));π DivideByBCD(WrkVal);π Dispose(WrkVal, Done);πend;ππprocedure TBCD.AbsoluteValue;πbeginπ SetSign(BCDPositive);πend;ππprocedure TBCD.Increment;πbeginπ AddReal(1);πend;ππprocedure TBCD.Decrement;πbeginπ SubtractReal(1);πend;ππprocedure TBCD.ShiftLeft(ShiftAmount: Byte);πvarπ i: integer;πbeginπ if ShiftAmount = 0 then exit;π for i := 1 to (BCDSize - ShiftAmount) doπ Value^[i] := Value^[i+ShiftAmount];π for i := ((BCDSize - ShiftAmount) + 1) to BCDSize doπ Value^[i] := 0;πend;ππprocedure TBCD.ShiftRight(ShiftAmount: Byte);πvarπ i: integer;πbeginπ if ShiftAmount = 0 then exit;π for i := BCDSize downto (ShiftAmount + 1) doπ Value^[i] := Value^[i - ShiftAmount];π for i := ShiftAmount downto 1 doπ Value^[i] := 0;πend;ππfunction TBCD.BCD2Int: LongInt;πvarπ i: integer;π wrkLongInt: LongInt;πbeginπ BCD2Int := 0;π if Precision = GetBCDSize then exit;ππ wrkLongInt := 0;π i := 1;π repeatπ wrkLongInt := wrkLongInt * 10;π wrkLongInt := wrkLongInt + Value^[i];π inc(i);π until i = (GetBCDSize - GetPrecision);π if GetSign = BCDNegative thenπ BCD2Int := -wrkLongIntπ elseπ BCD2Int := wrkLongInt;πend;ππfunction TBCD.BCD2Real: Real;πvarπ i: integer;π wrkIntegerPart, wrkFractionPart: real;πbeginπ BCD2Real := 0.0;π wrkIntegerPart := 0;π wrkFractionPart := 0;ππ if GetPrecision < GetBCDSize thenπ beginπ i := 1;π repeatπ wrkIntegerPart := wrkIntegerPart * 10.0;π wrkIntegerPart := wrkIntegerPart + Value^[i];π inc(i);π until i = (GetBCDSize - GetPrecision + 1);π end;ππ if Precision > 0 thenπ beginπ i := GetBCDSize;π repeatπ wrkFractionPart := wrkFractionPart + Value^[i];π wrkFractionPart := wrkFractionPart / 10.0;π dec(i);π until i = (GetBCDSize - GetPrecision);π end;ππ if GetSign = BCDNegative thenπ BCD2Real := -(wrkIntegerPart + wrkFractionPart)π elseπ BCD2Real := (wrkIntegerPart + wrkFractionPart);πend;ππfunction TBCD.PicStr(picture: string;π Width: Integer; BlankWhenZero: Boolean): String;ππvarπ integer_str, decimal_str, pic_str, val_str: string;π decimal_encountered, significant_digits_encountered: boolean;π number_of_digits, number_of_integer_digits, number_of_decimal_digits,π sub_pic, sub_val, i: integer;ππbegin {pic}π decimal_encountered := false;π number_of_digits := 0;π number_of_integer_digits := 0;π for i := 1 to length(picture) doπ if upcase(picture[i]) in ['$', '-', '9', 'Z'] thenπ beginπ inc(number_of_digits);π if not decimal_encountered thenπ inc(number_of_integer_digits);π endπ else if picture[i] = '.' thenπ decimal_encountered := true;π number_of_decimal_digits := number_of_digits - number_of_integer_digits;ππ integer_str := '';π for i := (GetBCDSize - GetPrecision) downto 1 doπ integer_str := char(ord('0')+Value^[i]) + integer_str;π if length(integer_str) > number_of_integer_digits thenπ delete(integer_str, 1, length(integer_str)-number_of_integer_digits)π elseπ while length(integer_str) < number_of_integer_digits doπ integer_str := '0' + integer_str;ππ decimal_str := '';π for i := (GetBCDSize - GetPrecision + 1) to GetBCDSize doπ decimal_str := decimal_str + char(ord('0')+Value^[i]);π if length(decimal_str) > number_of_decimal_digits thenπ delete(decimal_str, number_of_decimal_digits+1, 255)π elseπ while length(decimal_str) < number_of_decimal_digits doπ decimal_str := decimal_str + '0';ππ val_str := integer_str + decimal_str;ππ pic_str := copy(st_Blanks, 1, length(picture));ππ significant_digits_encountered := false;π sub_pic := 1;π sub_val := 1;π while sub_pic <= length(picture) doπ beginπ if val_str[sub_val] in ['1'..'9']thenπ significant_digits_encountered := true;π if upcase(picture[sub_pic]) in ['(', ')'] thenπ if Sign = BCDNegative thenπ beginπ pic_str[sub_pic] := upcase(picture[sub_pic]);π sub_pic := sub_pic + 1;π endπ elseπ beginπ pic_str[sub_pic] := ' ';π sub_pic := sub_pic + 1;π endπ else if upcase(picture[sub_pic]) in ['Z', '$', '-'] thenπ beginπ if significant_digits_encountered thenπ pic_str[sub_pic] := val_str[sub_val]π elseπ pic_str[sub_pic] := ' ';π sub_pic := sub_pic + 1;π sub_val := sub_val + 1;π endπ else if picture[sub_pic] = '.' thenπ beginπ pic_str[sub_pic] := '.';π sub_pic := sub_pic + 1;π significant_digits_encountered := true;π endπ else if picture[sub_pic] = '9' thenπ beginπ pic_str[sub_pic] := val_str[sub_val];π if pic_str[sub_pic] = ' ' then pic_str[sub_pic] := '0';π sub_pic := sub_pic + 1;π sub_val := sub_val + 1;π significant_digits_encountered := true;π endπ else if picture[sub_pic] = ',' thenπ beginπ if pic_str[sub_pic - 1] = ' ' thenπ pic_str[sub_pic] := ' 'π elseπ pic_str[sub_pic] := ',';π sub_pic := sub_pic + 1;π endπ elseπ beginπ pic_str[sub_pic] := upcase(picture[sub_pic]);π sub_pic := sub_pic + 1;π end;π end;ππ if Sign = BCDNegative thenπ beginπ sub_pic := 0;π while (sub_pic < length(picture)) andπ (picture[sub_pic + 1] in ['(', '-', ',']) doπ sub_pic := sub_pic + 1;π while (sub_pic > 0) andπ (pic_str[sub_pic] <> ' ') doπ sub_pic := sub_pic - 1;π if (sub_pic > 0) andπ (picture[sub_pic] <> '(') thenπ pic_str[sub_pic] := '-';π end;ππ sub_pic := 0;π while (sub_pic < length(picture)) andπ (picture[sub_pic + 1] in ['(', '$', ',']) doπ sub_pic := sub_pic + 1;ππ while (sub_pic > 0) andπ (pic_str[sub_pic] <> ' ') doπ sub_pic := sub_pic - 1;ππ if (sub_pic > 0) andπ (picture[sub_pic] <> '(') thenπ pic_str[sub_pic] := '$';ππ if (BlankWhenZero) and (pic_str = BCDZero^.PicStr(picture, bpw_Fixed, false)) thenπ pic_str := copy(st_Blanks, 1, length(picture));ππ if Width = bpw_fixed thenπ PicStr := pic_strπ elseπ beginπ if pic_str[1] = ' ' thenπ beginπ sub_pic := 1;π while (sub_pic < length(pic_str)) andπ (pic_str[sub_pic] = ' ') doπ inc(sub_pic);π if pic_str[sub_pic] <> ' ' then dec(sub_pic);π delete(pic_str, 1, sub_pic);π end;π if pic_str[length(pic_str)] = ' ' thenπ beginπ sub_pic := length(pic_str);π while (sub_pic > 1) andπ (pic_str[sub_pic] = ' ') doπ dec(sub_pic);π if pic_str[sub_pic] <> ' ' then inc(sub_pic);π delete(pic_str, sub_pic, 255);π end;π PicStr := pic_str;π end;πend;ππfunction TBCD.StrPic(dest: PChar; picture: string;π Width: Integer; BlankWhenZero: Boolean;π Size: Integer): PChar;πvarπ WrkStr: array[0..300] of char;πbeginπ if dest = nil thenπ beginπ StrPic := nil;π exit;π end;ππ StrPCopy(WrkStr, PicStr(picture, Width, BlankWhenZero));π StrLCopy(dest, WrkStr, Size);π StrPic := dest;πend;ππfunction TBCD.CompareBCD(AVal: PBCD): Integer;πvarπ i: integer;π BCD1, BCD2: PBCD;πbeginπ if AVal = nil then exit;ππ if GetSign < AVal^.GetSign thenπ beginπ CompareBCD := -1;π exit;π endπ else if GetSign > AVal^.GetSign thenπ beginπ CompareBCD := +1;π exit;π end;ππ BCD1 := new(PBCD, InitBCD(@Self));π BCD2 := new(PBCD, InitBCD(AVal));π if GetBCDSize > AVal^.GetBCDSize thenπ BCD2^.SetBCDSize(GetBCDSize)π elseπ BCD1^.SetBCDSize(AVal^.GetBCDSize);ππ CompareBCD := 0;π for i := 1 to BCD1^.GetBCDSize doπ beginπ if BCD1^.Value^[i] < BCD2^.Value^[i] thenπ beginπ if BCD1^.GetSign = BCDNegative thenπ CompareBCD := +1π elseπ CompareBCD := -1;π Dispose(BCD1, Done);π Dispose(BCD2, Done);π exit;π endπ else if BCD1^.Value^[i] > BCD2^.Value^[i] thenπ beginπ if BCD1^.GetSign = BCDNegative thenπ CompareBCD := -1π elseπ CompareBCD := +1;π Dispose(BCD1, Done);π Dispose(BCD2, Done);π exit;π end;π end;πend;ππfunction TBCD.CompareReal(AVal: Real): Integer;πvarπ WrkVal: PBCD;πbeginπ WrkVal := new(PBCD, InitReal(AVal, GetPrecision, GetBCDSize));π CompareReal := CompareBCD(WrkVal);π Dispose(WrkVal, Done);πend;ππfunction TBCD.ComparePChar(AVal: PChar): Integer;πvarπ WrkVal: PBCD;πbeginπ WrkVal := new(PBCD, InitPChar(AVal, GetPrecision, GetBCDSize));π ComparePChar := CompareBCD(WrkVal);π Dispose(WrkVal, Done);πend;ππbeginπ BCDZero := new(PBCD, InitReal(0.0, 2, 3));π RegisterType(RBCD);πend.ππ{ DOCUMENTATION }ππAJCBCD - Binary Coded Decimal (BCD) UnitπππThis unit was written using Borland International's Borland Pascal v7.0, andπthe Object Windows Library (OWL)/Turbo Vision (TV) library objects providedπwith that product.ππππI have not copyrighted this program, and donate it to the public domain. Allπportions of this program may be used, modified, and/or distributed, in wholeπor in part.πππI wrote this unit to provide myself with some reusible functions that wouldπprovide support for BCD math similar to what I've grown accustomed to withπthe COBOL Packed Decimal (COMP-3) data type. Note that in true "PackedπDecimal", two decimal digits are "packed" into each data byte. I chose notπto implement my BCD support in that manner. I may be less efficient in termsπof space, but I simply placed a single decimal digit in each byte.ππI am just a "hobby" programmer, having written nothing for anyone byt myself.πTherefore, this unit may not be "elegant"; and, there are certainly betterπways of implementing some of the routines that I coded (like perhaps codingπsome in assembler which I'm NOT very good at). However, it has met my ownπneeds, and I'm actually a little proud of what I accomplished hereπ(especially in being able to figure out algorithms to multiply and divide!).πBy the way, let me admit one thing right up front...I have NOT tested ALL ofπthe routines in this unit (in particular, the Divide routine). I clearlyπmarked all of the routines that have not been fully tested. You can assumeπthat all other routines HAVE been tested, because I used them in a realπapplication.ππThis might not be the best BCD routines available, but they might actually beπusefull to someone else--besides, it's free! I am open to suggestions,πcomments, or enhancements (although, I can't promise quick turn around becauseπI have a real job, plus I teach, plus I have a family--then I code for funπ--in that order <grin>). My CompuServe ID is 71331,501.ππThis unit exports some constants (described below). But, the big deal inπthis unit is the Binary Coded Decimal object that this unit defines. Thisπobject (TBCD) allows you to allocate a BCD data type of any number of digits.πThis object then provides methods for adding, subtracting, multiplying,πand dividing to/from/by other numbers. It also has methods for alteringπthe number of digits stored as well as the precision (number of places afterπthe decimal place).πππConstantsπ---------πDigitSize - Stores the size, in bytes, of each individual digit (currentlyπ one byte).ππbpw_Fixed - Passed to the PicSTR and STRPic methods (see the description ofπ PicSTR for an explanation of how to use this constant).ππbpw_Variable - See bpw_Fixed above.ππbpz_Blank - See bpw_Fixed above.ππbpz_NotBlank - See bpw_Fixed above.ππMaxBCDSize - Limits the maximum number of BCD digits that can be allocatedπ for a BCD object. Arbitrarily set to 100.ππst_Blanks25 - A string constant containing 25 blanks. Used just as aπ convenience in building the st_Blanks constant (see below).ππst_Blanks - A String constant containing 255 blanks. Used simply as aπ convenient reference/resource for lots of blanks (sort of likeπ the "SPACES" constant in COBOL).ππRBCD - TStreamRec used for registering the TBCD object type for use withπ streams.πππVarπ---πBCDZero - A PBCD object that is initialized to a value of zero in the unit'sπ initialization section. Used as a convenience whenever you needπ a BCD object with a value of zero.πππTypeπ----πTBCDArray - An array of "MaxBCDSize" (100) bytes. Allocated by the TBCDπ object to store the BCD value. Each byte stores an individualπ digit of the value.ππTBCDSign - An enumerated data type used by the TBCD object to represent theπ sign of the BCD value. Valid values are "BCDNegative" andπ "BCDPositive".πππππTBCDπ-----------------------------------------------------------------------------π TObject TBCDπ┌──────┐ ┌─────────────────────────────────┐π│ │ │ BCDSize │π├──────┤ │ Sign │π│ Init │ │ Value │π│*Done │ │ Precision │π│ Free │ ├─────────────────────────────────┤π└──────┘ │ InitBCD MultiplyByBCD │π │ InitReal MultiplyByReal │π │ InitPChar MultiplyByPChar │π │ Done DivideByBCD │π │ Load DivideByReal │π │ Store DivideByPChar │π │ GetValue AbsoluteValue │π │ GetSign Increment │π │ GetPrecision Decrement │π │ GetBCDSize ShiftLeft │π │ SetValueBCD ShiftRight │π │ SetValueReal BCD2Int │π │ SetValuePChar BCD2Real │π │ SetSign PicStr │π │ SetPrecision StrPic │π │ SetBCDSize CompareBCD │π │ AddBCD CompareReal │π │ AddReal ComparePChar │π │ AddPChar │π │ SubtractBCD │π │ SubtractReal │π │ SubtractPChar │π └─────────────────────────────────┘ππFields ---------------------------------------------------------------------ππBCDSize: Integer; Read OnlyππThe size, in number of digits, of the BCD number. Count represents theπavailable space for digits, and does NOT include the decimal point, or sign.πππSign: TBCDSign; Read OnlyππThe mathmatical sign of the current value (i.e., indicates whether theπcurrent value is positive or negative).πππValue: PBCDArray; Read OnlyππA pointer to a TBCDArray (an array of bytes) used to store the value of theπBCD number. Even though TBCDArray is defined with "MaxBCDSize" entries, onlyπBCDSize bytes are actually allocated from memory. Therefore, you must beπsure to be careful never to read or write to subscript values greater thanπBCDSize. If you need to change the number of digits allocated you should useπthe SetBCDSize method. The BCD value is stored in the array with the lowestπorder digit in the BCDSize position and the highest order digit in the 1stπposition. For example, if BCDSize is 5, Precision is 2, and the value beingπstored is 2.35, then a 5-byte array would be allocated on the heap, and theπarray values would be (in order from position 1 to 5) (0, 0, 2, 3, 5).πππPrecision: Byte; Read OnlyππThis value represents the number of digits after the decimal point. Keep inπmind that there is no actual decimal point stored.πππMethods ---------------------------------------------------------------------ππInitBCDππconstructor InitBCD(AVal: PBCD);ππSets BCDSize, Sign, and Precision to the same values as the BCD objectπreferred to by AVal. It then calls SetValueBCD passing AVal in order toπallocate a TBCDArray for Value, and copies the AVal^.Value into this object'sπValue array.πππInitRealππconstructor InitReal(AVal: Real; APrec: byte; ASize: Integer);ππSets BCDSize to ASize, Precision to APrec, then calls SetValueReal(AVal) inπorder to allocate a Value array and initialize it with the value in AVal.πππInitPChar ** Not yet tested **ππconstructor InitPChar(AVal: PChar; APrec: byte; ASize: Integer);ππSets BCDSize to ASize, Precision to APrec, then calls SetValuePChar(AVal)πin order to allocate a Value array and initialize it with the value in AVal.πππDoneππdestructor Done; virtual;ππFrees the memory allocated for the Value array and calls "inherited Done".πππLoadππconstructor Load(var S: TStream);ππconstructs and loads a BCD object from the stream S by first loading BCDSize,πSign, the Value array, and last the Precision.πππStoreππprocedure Store(var S: TStream);ππStores the BCD object on the stream S by storing the BCDSize, Sign, Valueπarray, and the Precision.πππGetValueππfunction GetValue: PBCDArray;ππAllocates a new TBCDArray of size BCDSize and copies the value in Value intoπthe new array, then returns a pointer to the new array. Note that it willπbe the calling routine's responsibility for disposing the array pointed to byπthe returned pointer (use GetBCDSize to determine how much memory to free).πFreeMem should be used for this disposal, not Dispose.πππGetSignππfunction GetSign: TBCDSign;ππReturns the sign of the BCD value. The sign is returned as a TBCDSignπvalue; either "BCDNegative", or "BCDPositive".πππGetPrecisionππfunction GetPrecision: Byte;ππReturns a byte value equal to the Precision (number of decimal places) of theπBCD number.πππGetBCDSizeππfunction GetBCDSize: Inteteger;ππReturns an integer value representing the number of BCD digits allocated inπthe Value array.πππSetValueBCDππprocedure SetValueBCD(AVal: PBCD);ππIf Value is not nil, then the current Value array is freed. Next, a new arrayπof size BCDSize is allocated on the heap, by calling AVal^.GetValue. Next,πthe copied value array is adjusted from the size and precision of AVal toπthe BCDSize and Precision of this BCD object (if different). Lastly, theπsign of the value is copied by calling AVal^.GetSign.πππSetValueRealππprocedure SetValueReal(AVal: Real);ππThe current value array is initialized to all zero digits. AVal is convertedπto a string, and that string is copied digit by digit into the array. IfπAVal is less than zero then Sign is set to BCDNegative, otherwise it is setπto BCDPositive.πππSetValuePChar ** Not Tested Yet **ππprocedcure SetValuePChar(AVal: PChar);ππThe current value array is initialized to all zero digits. AVal is copiedπinto the array digit by digit. This routine validity checking to verify thatπthe string actually represents a numeric value. The only character valuesπthat are processed are: 1) numbers (0-9), 2) period (locates decimal point),πand 3) minus sign or parentheses to determine that the sign is negative.πExamples: "(123.45)" would be interpreted as negative 123.45; "123.45" wouldπbe interpreted as positive 123.45; "-123.45" would be interpreted as negativeπ123.45. Likewise, "555-55-5555" would be interpreted as a negativeπ555555555; and "I'll have 2" would be interpreted as a positive 2. If thereπare no number characters in the string at all, then the resulting value isπzero.πππSetSignππprocedure SetSign(ASign: TBCDSign);ππSets Sign to ASign (either BCDNegative or BCDPositive). Regardless of theπvalue of ASign, if the Value of the BCD is zero, then SetSign forces Sign toπbe BCDPositive (in otherwords, BCD never stores a negative zero).πππSetPrecisionππprocedure SetPrecision(APrec: Byte);ππSets Precision to APrec. It also shifts the value array left or right,πdepending on whether the precision is being increased or decreased. If theπdecimals are shifted left, dropping high order digits (hopefully zeros), andπpadding zeros on the right. If the precision is being decreased, the digitsπare shifted to the right, padding the high order digits with zeros, andπdropping low order digits. Note that the size of the value array is NOTπchanged by this method.πππSetBCDSizeππprocedure SetBCDSize(ASize: Integer);ππSets BCDSize to ASize. It also allocates a new value array of the new size,πand copies value from the original value array to the new one. The valueπis copied right justified (in otherwords, high order digits are droppedπor padded with zeros depending on whether the new size is larger or smallerπthan the old size). The original value array is freed, and Value is set toπpoint to the new value array.πππAddBCDππprocedure AddBCD(AVal: PBCD);ππAdds AVal^.Value to Self.Value. This is a "signed add". By that I mean that theπsigns of the two operands ARE taken into account when adding the two valuesπtogether. The result is stored in the Value array. Mathmatically, it mightπbe represented by the following formula: "Self := Self + AVal;"πππAddRealππprocedure AddReal(AVal: Real);ππConverts AVal to a temporary PBCD object and calls AddBCD to add thatπtemporary BCD number to Self.πππAddPChar ** Not yet tested **ππprocedure AddPChar(AVal: PChar);ππConverts AVal to a temporary PBCD object and calls AddBCD to add thatπtemporary BCD number to Self.πππSubtractBCDππprocedure SubtractBCD(AVal: PBCD);ππSubtracts AVal^.Value from Self.Value. This is a "signed subtract". By thatπI mean that the signs of the two operands ARE taken into account whenπsubtracting the two values. The result is stored in the Value array.πMathmatically, it might be represented by the following formula:π"Self := Self - AVal;"πππSubtractReal ** Not yet tested **ππprocedure SubtractReal(AVal: Real);ππConverts AVal to a temporary PBCD object and calls SubtractBCD to subtractπthat temporary BCD number from Self.πππSubtractPChar ** Not yet tested **ππprocedure SubtractPChar(AVal: PChar);ππConverts AVal to a temporary PBCD object and calls SubtractBCD to subtractπthat temporary BCD number from Self.πππMultiplyByBCDππprocedure MultiplyByBCD(AVal: PBCD);ππMultiplies Self.Value by AVal^.Value. This is a "signed multiply". By thatπI mean that the signs of the two operands ARE taken into account whenπmultiplying the two values. The result is stored in the Value array.πMathmatically, it might be represented by the following formula:π"Self := Self * AVal;"πππMultiplyByReal ** Not yet tested **ππprocedure MultiplyByReal(AVal: Real);ππConverts AVal to a temporary PBCD object and calls MultiplyByBCD toπmultiply Self by that temporary BCD number.πππMultiplyByPChar ** Not yet tested **ππprocedure MultiplyByPChar(AVal: PChar);ππConverts AVal to a temporary PBCD object and calls MultiplyByBCD toπmulitiply Self by that temporary BCD number.πππDivideByBCD ** Not yet tested **ππprocedure DivideByBCD(AVal: PBCD);ππDivides Self.Value by AVal^.Value. This is a "signed divide". By thatπI mean that the signs of the two operands ARE taken into account whenπdividing the two values. The result is stored in the Value array.πMathmatically, it might be represented by the following formula:π"Self := Self/AVal;"πππDivideByReal ** Not yet tested **ππprocedure DivideByReal(AVal: Real);ππConverts AVal to a temporary PBCD object and calls DivideByBCD to divideπSelf by that temporary BCD number.πππDivideByPChar ** Not yet tested **ππprocedure DivideByPChar(AVal: Real);ππConverts AVal to a temporary PBCD object and calls DivideByBCD to divideπSelf by that temporary BCD number.πππAbsoluteValueππprocedure AbsoluteValue;ππCalls SetSign to set Sign to BCDPositive, regardless of its current value.πππIncrement ** Not yet tested **ππprocedure Increment;ππAdds 1 Value.πππDecrement ** Not yet tested **ππprocedure Decrement;ππSubtracts 1 from Value.πππShiftLeftππprocedure ShiftLeft(ShiftAmount: Byte);ππShifts all of the digits left by ShiftAmount, dropping high order digits, andπpadding the low order digits with zeros. The Precision of the number is NOTπaltered. In effect, ShiftLeft multiplies Value by a power of 10.πππShiftRightππprocedure ShiftRight(ShiftAmount: Byte);ππShifts all of the digits right by ShiftAmount, dropping low order digits, andπpadding the high order digits with zeros. The Precision of the number is NOTπaltered. In effect, ShiftRight divides Value by a power of 10.πππBCD2Int ** Not yet tested **ππfunction BCD2Int: LongInt;ππConverts the BCD value (and it's sign) to a LongInt data value. Decimalπpositions are simply truncated, not rounded. Range checking is not performed.πIf the number of significant digits of the BCD number (not counting decimalπpositions) is too large for a LongInt number, high order digits are lost,πand the resulting LongInt value will probably be meaningless.πππBCD2Real ** Not yet tested **ππfunction BCD2Real: Real;ππConverts the BCD value (and it's sign) to a Real data value. Range checkingπis not performed. If the number of significant digits of the BCD number isπtoo loarge for a Real number, the results are unpredictable, and willπprobably be meaningless.πππPicStrππfunction PicStr(picture: string;π Width: Integer; BlankWhenZero: Boolean): string;ππPicStr converts the BCD number into a formatted Pascal string. If you areπfamiliar with the used of Edit Numeric Formatting in Cobol, then you're aπlong ways toward understanding how to use this routine.ππFirst, let's get the simple parameters out of the way...ππWidth indicates whether or not insignificant leading and trailing blanksπshould be removed from the resulting string. If Width is equal to 0 then theπlength of the resulting string will always equal the length of Picture,πregardless of any leading or trailing blanks in the result string. If Widthπis equal to 1, then any leading and/or trailing blanks will be removed fromπthe resulting string before returning. For your convenience, two constantsπhave been defined for use with this parameter: bpw_Fixed = 0 andπbpw_Variable = 1.ππBlankWhenZero indicates whether the entire result string should be forced toπcompletely blank, regardless of any formatting characters in Picture, if theπformatted value is logically equal to zero. The BCD value itself is NOT usedπto make this determination. The determination is made by comparing theπresult string to the string from formatting BCDZero (zero value) with theπsame Picture string. If the two strings are equal, then this result stringπis considered to be equal to zero. If BlankWhenZero is true, then such zeroπvalued results are forced to all blanks. If BlankWhenZero is false, theπthe result string is left to whatever it becomes based on the Picture string.πIf BlankWhenZero is true, and Width = bpw_Fixed, then the result string isπa string of blanks equal in length to the length of Picture. If Width =πbpw_Variable, the the result will be an empty strint (''). For example, ifπthe BCD number = 0.0023, and the formatted result is "0.00%", BlankWhenZero =πfalse would result in "0.00%", while BlankWhenZero = true would result in aπblank or empty string depending on Width. For your convenience, two constantsπhave been defined for use with this parameter: bpz_Blank = true, andπbpz_NotBlank = false.ππNow, the more complicated part...picture...ππThe "picture" parameter is a string that provides a template for formattingπthe value of the BCDnumber. The possible template characters are...π '9' - Fills with a digit from the value (or zero if no digit positionπ available in the BCD number)π 'Z' - Just like '9', except that insignificant zeros (i.e., leading zeros)π are left blank.π 'z' - Exactly the same as a capital "Z"π '$' - Just like 'Z', except that the right most unused (blank)π dollar-sign position is filled with a '$'. COBOL afficianados willπ recognize this as a "floating dollar sign".π '-' - Just like 'Z', except that if the BCD number value is negative, thenπ the right most unused (blank) dash position is filled with a '-'.π COBOL afficianoados will recognize this as a "floating negative sign".π '(' - If the template contains a parenthesis, and the BCD number value isπ negative, then the result string is surrounded with parenthesis.π ')' - If the template contains a parenthesis, and the BCD number value isπ negative, then the result string is surrounded with parenthesis.π '.' - Indicates the decimal point position, and is included in the resultπ string. If the template does not contain a period, then the decimalπ position is assumed to be at the right end of the template, noπ decimal point is included in the result string, and no decimal placeπ values are included in the result string.π ',' - If any significant (non-zero) value positions precede the commaπ position, then a comma is inserted at this position in the resultπ string. This would normally be used to format commas to separateπ thousands positions in large numbers.π ANY other characters are simply inserted into the result string in theirπ relative position.ππSome examples might help...ππ Value Picture String Fixed Result Variable Resultπ 123.45 '$$$$$9.99' ' $123.45' '$123.45'π 123456.78 '$$$$$9.99' '123456.78' '123456.78'π 123456.78 '$$$$$$9.99' '$123456.78' '$123456.78'π 123456.78 '$,$$$,$$9.99' '$123,456.78' '$123,456.78'π 123.45 '9999' '0123' '0123'π -1234.6 '---,--9.99' ' -1,234.60' '-1,234.60'π -10.15 '(99.99)' '(10.15)' '(10.15)'π 10.15 '(99.99)' ' 10.15 ' '10.15'π 75 'z9.999%' '75.000%' '75.000%'ππGot the idea? I hope so. I have developed a similar stand-alone routineπfor formatting inteter and real numbers, and find it to be a VERY handy wayπto nicely format my number values for presentation on the screen or on aπpaper report.πππStrPic ** Not yet tested **ππfunction StrPic(dest: PChar; picture: string;π Width: Integer; BlankWhenZero: Boolean): PChar;ππCalls PicStr(picture, Width, BlankWhenZero) to get a formatted Pascal string.πThis string is converted to an null terminated string. StrLCopy is used toπcopy that null terminated string to Dest, limited by Size. See PicStr for anπexplanation of the use of picture, Width, and BlankWhenZero. StrPic returnsπa pointer to dest.πππCompareBCDππfunction CompareBCD(AVal: PBCD): Integer;ππCompares the signed values of Self and AVal. CompareBCD returns -1 if Selfπis less than AVal, returns +1 of Self is greater than AVal, and returns 0 ifπthe two values are equal.πππCompareReal ** Not yet tested **ππfunction CompareReal(AVal: Real): Integer;ππConverts AVal to a temporary PBCD object and calls CompareBCD to perform theπactual comparison with that temporary BCD number. CompareReal returns theπvalue returned by CompareBCD.ππComparePChar ** Not yet tested **πππfunction ComparePChar(AVal: PChar): Integer;ππConverts AVal to a temporary PBCD object and calls CompareBCD to perform theπactual comparison with that temporary BCD number. ComparePChar returns theπvalue returned by CompareBCD. 2 08-24-9413:24ALL EUGENE VENTIMIGLIA Type Really Big Number SWAG9408 =á· 25 ₧ {π I wrote routines to add and multiply any amount of bytes one at a time,π but then had no way to test them out:)π}πprogram Really_Big_Math;ππtype ReallyBigNumber = array[0..100] of byte;π {Byte [0] is the length, [1] is least significant}ππprocedure ShiftRBN(var A:ReallyBigNumber;N:byte);πvar Index:Byte;πbeginπ if n<>0 then beginπ for Index :=(A[0] + N) downto N+1 do A[Index] := A[Index - N];π for Index := 1 to N do A[Index] := 0;π Inc(A[0],N);π end;πend;ππprocedure ByteAdd(A,B:Byte; var C,S:byte);πvar temp:word;πbeginπ temp := A+B+C;π C := temp div 256;π S := temp mod 256;πend;ππProcedure ByteMult(A,B:Byte;var C,P:byte);πvar temp:word;πbeginπ temp:=A*B+C;π C:=temp div 256;π P:=temp mod 256;πend;πππProcedure Sum(N1,N2:ReallyBigNumber;var S:ReallyBigNumber);πvar WorkArray : ReallyBigNumber;π L,Index,π Carry : byte;ππbeginπ Carry := 0;WorkArray[0] := 0;π if N1[0] = 0 then for Index := 1 to 100 do N1[Index] := 0;π if N2[0] = 0 then for Index := 1 to 100 do N2[Index] := 0;π if N1[0] > N2[0] then L := N1[0] else L := N2[0];π for Index := 1 to L do beginπ ByteAdd(N1[Index],N2[Index],Carry,WorkArray[Index]);π inc(WorkArray[0]);π end;π if Carry <> 0 then inc(WorkArray[0]);π WorkArray[L+1]:= Carry;π S := WorkArray;πend;ππprocedure Product(N1,N2:ReallyBigNumber;var PR:ReallyBigNumber);πvar C1,C2,L1,L2,π Carry :Byte;π TProduct,π WorkRBN :ReallyBigNumber;πbeginπ WorkRBN[0] := 0;π L1 := N1[0];L2 := N2[0];π for C1 := 1 to L1 do beginπ Carry:=0;TProduct[0]:=0;π for C2 := 1 to L2 do beginπ ByteMult(N1[C1],N2[C2],Carry,TProduct[C2]);π inc(TProduct[0]);π end;π if Carry<>0 then beginπ TProduct[C2+1] := Carry;π inc(TProduct[0]);π end;π ShiftRBN(TProduct,C1-1);π Sum(TProduct,WorkRBN,WorkRBN)π end;π PR := WorkRBN;πend;ππprocedure STR2RBN(S:String; var R:ReallyBigNumber);ππvar Index,π SLen : Byte;π Value,π RBNTen,π RBNPlus : ReallyBigNumber;ππ function Ch2Val(C:Char):Byte;π beginπ Ch2Val := ord(C) - 48;π end;ππbeginπ SLen := Length(S);π RBNTen[0] := 1; RBNTen[1] := 10; {To Multiply Value by Ten}π RBNPlus[0] := 1; RBNPlus[1] := 0; {To add to Value}π Value[0] := 1; Value[1] := Ch2Val(S[1]);π if SLen > 1 thenπ for Index := 2 to SLen do begin (***THANKS DJ!!***)π RBNPlus[1] := Ch2Val(S[Index]);π Product(RBNTen,Value,Value);π Sum(RBNPlus,Value,Value);π end;π R := Value;πend;ππprocedure RBN2Real(RBN:ReallyBigNumber;var RR:Real);πvar RValue:Real;πbeginπ RValue:=0;π repeatπ RValue := RValue * 256;π RValue := RValue + RBN[RBN[0]];π dec(RBN[0]);π until RBN[0] < 1;π RR := RValue;πend;ππvar AA,BB,SS,PP: ReallyBigNumber;π StA,StB : String;π RealP,RealS : Real;ππbeginπ Writeln('Input A');π Readln(StA);π Writeln('Input B');π Readln(StB);π STR2RBN(StA,AA);π STR2RBN(StB,BB);π Sum(AA,BB,SS);π Product(AA,BB,PP);π RBN2Real(SS,RealS);π RBN2Real(PP,RealP);π Writeln('Sum =',RealS);π Writeln('Product =',RealP);πend.π 3 08-24-9413:51ALL DAVE NEMETH Prime Numbers SWAG9408 ╒,░] 8 ₧ {πI'm studying pascal on my own and was given an assignment to determine if aπpositive number is prime. This was in a chapter where functions wereπdiscussed. I've struggled with this problem for a week and have given up. Theπfollowing code is the best I can come up with. It is not correct. Wouldπsomeone please evaluate this and tell me what is wrong with it?π}ππPROGRAM PrimeNumbers;π{ Exercise to determine if a positive number is a prime }πVAR x : WORD;π πFUNCTION prime (p : WORD) : BOOLEAN;πBEGIN { Prime }π prime := (p MOD 2 <> 0) AND (p MOD 3 <> 0) AND (p MOD 5 <> 0)πEND; { Prime }ππBEGIN { Main }π REPEATπ WRITE ('Enter a positive number. 0 to quit: ');π READLN (x);π IF prime (x) THENπ WRITELN (x, ' is a prime number')π ELSEπ WRITELN (x, ' is NOT prime');π UNTILπ x = 0π END. { Main }π 4 08-24-9417:50ALL WIM VAN DER VEGT Text Formula Parser SWAG9408 δy ' 349 ₧ {---------------------------------------------------------}π{ Project : Text Formula Parser }π{ Auteur : G.W. van der Vegt }π{---------------------------------------------------------}π{ Datum .tijd Revisie }π{ 900530.1900 Creatie (function call/exits removed). }π{ 900531.1900 Revisie (Boolean expressions). }π{ 900104.2100 Revisie (HEAP Function Storage). }π{ 910327.1345 External Real string vars (tfp_realstr) }π{ are corrected the same way as the parser }π{ corrects them before using TURBO's VAL. }π{ 910829.1200 Support added for recursion with string }π{ variables so they may contain formula's }π{ now. }π{ 940411.1300 Hyperbolic, reciproke & inverse }π{ goniometric functions added, }π{ Type of tfp_lnr changed to Byte. }π{ Bug fixed in tfp_check (tfp_lnr not always}π{ initialized to 0) }π{---------------------------------------------------------}ππUNIT Tfp_02;ππINTERFACEππCONSTπ tfp_true = 1.0; {----REAL value for BOOLEAN TRUE }π tfp_false = 0.0; {----REAL value for BOOLEAN FALSE }π tfp_maxparm = 16; {----Maximum number of parameters }π tfp_funclen = 12; {----Maximum function name length }ππTYPEπ tfp_fname = STRING[tfp_funclen]; {----Function Name or Alias }π tfp_ftype = (tfp_noparm, {----Function or Function() }π tfp_1real, {----Function(VAR r) }π tfp_2real, {----Function(VAR r1,r2) }π tfp_nreal, {----Function(VAR r;n INTEGER) }π tfp_realvar, {----Real VAR }π tfp_intvar, {----Integer VAR }π tfp_boolvar, {----Boolean VAR }π tfp_strvar); {----String VAR (Formula) }ππ tfp_rarray = ARRAY[0..tfp_maxparm-1] OF REAL;ππFUNCTION Tfp_parse2real(s : STRING): REAL;ππFUNCTION Tfp_parse2str(s : STRING;m,n : INTEGER) : STRING;ππ{---------------------------------------------------------}π{----Interface to error functions for external addons }π{---------------------------------------------------------}ππVARπ tfp_erpos,π tfp_ernr : BYTE;ππPROCEDURE Tfp_seternr(ernr : INTEGER);ππFUNCTION Tfp_errormsg(nr : INTEGER) : STRING;ππ{---------------------------------------------------------}π{----Initialize & Expand internal parser datastructure }π{---------------------------------------------------------}ππPROCEDURE Tfp_init (no : WORD);ππPROCEDURE Tfp_expand(no : WORD);ππ{---------------------------------------------------------}π{----Keep first no function+vars of parser }π{---------------------------------------------------------}ππPROCEDURE Tfp_keep (no : WORD);ππ{---------------------------------------------------------}π{----Number of functions+vars added to parser }π{---------------------------------------------------------}ππFUNCTION Tfp_noobj : WORD;ππ{---------------------------------------------------------}π{----Adds own FUNCTION or VAR to the parser }π{ All FUNCTIONS & VARS must be compiled }π{ with the FAR switch on }π{---------------------------------------------------------}ππPROCEDURE Tfp_addobj(adres : POINTER;π name : tfp_fname;π ftype : tfp_ftype);ππ{---------------------------------------------------------}π{----Add Internal Function Packs }π{---------------------------------------------------------}ππPROCEDURE Tfp_addgonio;πPROCEDURE Tfp_addlogic;πPROCEDURE Tfp_addmath;πPROCEDURE Tfp_addmisc;πPROCEDURE Tfp_addall;ππ{---------------------------------------------------------}ππIMPLEMENTATIONππTYPEπ tfp_parse_state = RECORDπ tfp_line : STRING; {----Copy of string to Parse }π tfp_lp : BYTE; {----Parsing Pointer into Line }π tfp_nextchar : CHAR; {----Character at Lp Postion }π END;ππ tfp_state_ptr = ^tfp_parse_state;ππCONSTπ tfp_maxreal = +9.99999999e37; {----Internal maxreal }π tfp_maxlongint = maxlongint-1; {----Internal longint }ππVARπ maxfie : INTEGER; {----max no of functions & vars }π fiesiz : INTEGER; {----current no of functions & vars }π p : tfp_state_ptr; {----Top level formula }ππTYPEπ tfp_fie_typ = RECORDπ tfp_fname : tfp_fname;{----Name of function or var }π tfp_faddr : POINTER; {----FAR POINTER to function or var}π tfp_ftype : tfp_ftype;{----Type of entry }π END;ππ tfp_fieptr = ARRAY[1..1] OF tfp_fie_typ; {----Open Array Construction }ππVARπ fiearr : ^tfp_fieptr; {----Array of functions & vars }ππ{---------------------------------------------------------}π{----Tricky stuff to call FUNCTIONS }π{ Idea from Borland's DataBase ToolKit }π{---------------------------------------------------------}ππ{$F+}ππVARπ glueptr : POINTER;ππFUNCTION Tfp_call_noparm : REAL;ππ INLINE($ff/$1e/glueptr); {CALL DWORD PTR GluePtr}ππFUNCTION Tfp_call_1real(VAR lu_r) : REAL;ππ INLINE($ff/$1e/glueptr); {CALL DWORD PTR GluePtr}ππFUNCTION Tfp_call_2real(VAR lu_r1,lu_r2) : REAL;ππ INLINE($ff/$1e/glueptr); {CALL DWORD PTR GluePtr}ππFUNCTION Tfp_call_nreal(VAR lu_r,lu_n) : REAL;ππ INLINE($ff/$1e/glueptr); {CALL DWORD PTR GluePtr}ππ{$F-}ππ{---------------------------------------------------------}π{----TP round function not useable }π{---------------------------------------------------------}ππFUNCTION Tfp_round(VAR r : REAL) : LONGINT;ππBEGINπ IF (r<0)π THEN Tfp_round:= Trunc(r - 0.5)π ELSE Tfp_round:= Trunc(r + 0.5);πEND; {of Tfp_round}ππ{---------------------------------------------------------}π{----This routine set the tfp_ernr if not set already }π{---------------------------------------------------------}ππPROCEDURE Tfp_seternr(ernr : INTEGER);ππBEGINπ IF (tfp_ernr=0)π THENπ BEGINπ tfp_erpos:=p^.tfp_lp;π tfp_ernr :=ernr;π END;πEND; {of Tfp_Seternr}ππ{---------------------------------------------------------}π{----This routine skips one character }π{---------------------------------------------------------}ππPROCEDURE Tfp_newchar(p : tfp_state_ptr);ππBEGINπ WITH p^ DOπ BEGINπ IF (tfp_lp<Length(tfp_line))π THEN Inc(tfp_lp);π tfp_nextchar:=Upcase(tfp_line[tfp_lp]);π END;πEND; {of Tfp_Newchar}ππ{---------------------------------------------------------}π{----This routine skips one character and }π{ all folowing spaces from an expression }π{---------------------------------------------------------}ππPROCEDURE Tfp_skip(p : tfp_state_ptr);ππBEGINπ WITH p^ DOπ REPEATπ Tfp_newchar(p);π UNTIL (tfp_nextchar<>' ');πEND; {of Tfp_Skip}ππ{---------------------------------------------------------}π{----This Routine does some trivial check & }π{ Inits Tfp_State_Ptr^ }π{---------------------------------------------------------}ππPROCEDURE Tfp_check(s : STRING;p : tfp_state_ptr);ππVARπ i,j : INTEGER;ππBEGINπ WITH p^ DOπ BEGINπ tfp_lp:=0;ππ {----Test for match on numbers of ( and ) }π j:=0;π FOR i:=1 TO Length(s) DOπ CASE s[i] OFπ '(' : Inc(j);π ')' : Dec(j);π END;ππ IF (j=0)π THENπ {----Continue init}π BEGINπ {----Add a CHR(0) as an EOLN marker}π tfp_line:=s+#00;π Tfp_skip(p);ππ {----Try parsing if any characters left}π IF (tfp_line[tfp_lp]=#00) THEN Tfp_seternr(6);π ENDπ ELSE Tfp_seternr(3);π END;πEND; {of Tfp_Check}ππ{---------------------------------------------------------}π{ Number = Real (Bv 23.4E-5) }π{ Integer (Bv -45) }π{---------------------------------------------------------}ππFUNCTION Tfp_eval_number(p : tfp_state_ptr) : REAL;ππVARπ temp : STRING;π err : INTEGER;π value : REAL;ππBEGINπ WITH p^ DOπ BEGINπ {----Correct .xx to 0.xx}π IF (tfp_nextchar='.')π THEN temp:='0'+tfp_nextcharπ ELSE temp:=tfp_nextchar;ππ Tfp_newchar(p);ππ {----Correct ±.xx to ±0.xx}π IF (Length(temp)=1) ANDπ (temp[1] IN ['+','-']) ANDπ (tfp_nextchar='.')π THEN temp:=temp+'0';ππ WHILE tfp_nextchar IN ['0'..'9','.','E'] DOπ BEGINπ temp:=temp+tfp_nextchar;π IF (tfp_nextchar='E')π THENπ BEGINπ {----Correct ±xxx.E to ±xxx.0E}π IF (temp[Length(temp)-1]='.')π THEN Insert('0',temp,Length(temp));π Tfp_newchar(p);π IF (tfp_nextchar IN ['+','-'])π THENπ BEGINπ temp:=temp+tfp_nextchar;π Tfp_newchar(p);π END;π ENDπ ELSE Tfp_newchar(p);π END;ππ {----Skip trailing spaces}π IF (tfp_nextchar=' ')π THEN Tfp_skip(p);ππ {----Correct ±xx. to ±xx.0 but NOT ±xxE±yy.}π IF (temp[Length(temp)]='.') ANDπ (Pos('E',temp)=0)π THEN temp:=temp+'0';ππ Val(temp,value,err);ππ IF (err<>0) THEN Tfp_seternr(1);π END;ππ IF (tfp_ernr=0)π THEN Tfp_eval_number:=valueπ ELSE Tfp_eval_number:=0;ππEND; {of Tfp_Eval_Number}ππ{---------------------------------------------------------}π{ Factor = Number }π{ (External) Function() }π{ (External) Function(Expr) }π{ (External) Function(Expr,Expr) }π{ External Var Real }π{ External Var Integer }π{ External Var Boolean }π{ External Var realstring }π{ (R_Expr) }π{---------------------------------------------------------}ππFUNCTION Tfp_eval_b_expr(p : tfp_state_ptr) : REAL; forward;ππFUNCTION Tfp_eval_factor(p : tfp_state_ptr) : REAL;ππVARπ ferr : BOOLEAN;π param : INTEGER;π dummy : tfp_rarray;π value,π dummy1,π dummy2 : REAL;π temp : tfp_fname;π e,π i,π index : INTEGER;π temps : STRING;π tmpstate : tfp_state_ptr;ππBEGINπ WITH p^ DOπ CASE tfp_nextchar OFπ '+' : BEGINπ Tfp_newchar(p);π value:=+Tfp_eval_factor(p);π END;ππ '-' : BEGINπ Tfp_newchar(p);π value:=-Tfp_eval_factor(p);π END;ππ '0'..π '9',π '.' : value:=Tfp_eval_number(p);ππ 'A'..π 'Z' : BEGINπ ferr:=true;π temp:=tfp_nextchar;π Tfp_skip(p);π WHILE tfp_nextchar IN ['0'..'9','_','A'..'Z'] DOπ BEGINπ temp:=temp+tfp_nextchar;π Tfp_skip(p);π END;ππ {----Seek function and CALL it}π {$R-}π FOR index:=1 TO fiesiz DOπ WITH fiearr^[index] DOπ IF (tfp_fname=temp) THENπ BEGINπ ferr:=false;ππ CASE tfp_ftype OFππ {----Function or Function()}π tfp_noparm : IF (tfp_nextchar='(')π THENπ BEGINπ Tfp_skip(p);ππ IF (tfp_nextchar<>')')π THEN Tfp_seternr(14);ππ Tfp_skip(p);π END;ππ {----Function(r)}π tfp_1real : IF (tfp_nextchar='(')π THENπ BEGINπ Tfp_skip(p);ππ dummy1:=Tfp_eval_b_expr(p);ππ IF (tfp_ernr=0) ANDπ (tfp_nextchar<>')')π THEN Tfp_seternr(14);ππ Tfp_skip(p); {----Dump the ')'}π ENDπ ELSE Tfp_seternr(14);ππ {----Function(r1,r2)}π tfp_2real : IF (tfp_nextchar='(')π THENπ BEGINπ Tfp_skip(p);ππ dummy1:=Tfp_eval_b_expr(p);ππ IF (tfp_ernr=0) ANDπ (tfp_nextchar<>',')π THEN Tfp_seternr(14);ππ Tfp_skip(p); {----Dump the ','}π dummy2:=Tfp_eval_b_expr(p);ππ IF (tfp_ernr=0) ANDπ (tfp_nextchar<>')')π THEN Tfp_seternr(14);ππ Tfp_skip(p); {----Dump the ')'}π ENDπ ELSE Tfp_seternr(14);ππ {----Function(r,n)}π tfp_nreal : IF (tfp_nextchar='(')π THENπ BEGINπ param:=0;ππ Tfp_skip(p);π dummy[param]:=Tfp_eval_b_expr(p);ππ IF (tfp_ernr=0) ANDπ (tfp_nextchar<>',')π THEN Tfp_seternr(14)π ELSEπ WHILE (tfp_ernr=0) ANDπ (tfp_nextchar=',') ANDπ (param<tfp_maxparm-1) DOπ BEGINπ Tfp_skip(p); {----Dump the ','}π Inc(param);π dummy[param]:=Tfp_eval_b_expr(p);π END;ππ IF (tfp_ernr=0) ANDπ (tfp_nextchar<>')')π THEN Tfp_seternr(14);ππ Tfp_skip(p); {----Dump the ')'}π ENDπ ELSE Tfp_seternr(14);ππ {----Real Var}π tfp_realvar : dummy1:=REAL(tfp_faddr^);ππ {----Integer Var}π tfp_intvar : dummy1:=1.0*INTEGER(tfp_faddr^);ππ {----Boolean Var}π tfp_boolvar : dummy1:=1.0*Ord(BOOLEAN(tfp_faddr^));ππ {----Real string Var}π tfp_strvar : BEGINπ temps:=STRING(tfp_faddr^);π IF (Maxavail>=Sizeof(tfp_parse_state))π THENπ BEGINπ New(tmpstate);π Tfp_check(temps,tmpstate);π dummy1:=Tfp_eval_b_expr(tmpstate);π Dispose(tmpstate);π ENDπ ELSE Tfp_seternr(15);π END;π END;ππ IF (tfp_ernr=0)π THENπ BEGINπ glueptr:=tfp_faddr;ππ CASE tfp_ftype OFπ tfp_noparm : value:=Tfp_call_noparm;π tfp_1real : value:=Tfp_call_1real(dummy1);π tfp_2real : value:=Tfp_call_2real(dummy1,dummy2);π tfp_nreal : value:=Tfp_call_nreal(dummy,param);π tfp_realvar,π tfp_intvar,π tfp_boolvar,π tfp_strvar : value:=dummy1;π END;π END;π END;π {$R+}ππ IF (ferr=true)π THEN Tfp_seternr(2);π END;ππ '(' : BEGINπ Tfp_skip(p);ππ value:=Tfp_eval_b_expr(p);ππ IF (tfp_ernr=0) ANDπ (tfp_nextchar<>')')π THEN Tfp_seternr(3);ππ Tfp_skip(p); {----Dump the ')'}π END;ππ ELSE Tfp_seternr(2);π END;ππ IF (tfp_ernr=0)π THEN Tfp_eval_factor:=valueπ ELSE Tfp_eval_factor:=0;ππEND; {of Tfp_Eval_factor}ππ{---------------------------------------------------------}π{ Term = Factor ^ Factor }π{---------------------------------------------------------}ππFUNCTION Tfp_eval_term(p : tfp_state_ptr) : REAL;ππVARπ value,π exponent,π dummy,π base : REAL;ππBEGINπ WITH p^ DOπ BEGINπ value:=Tfp_eval_factor(p);ππ WHILE (tfp_ernr=0) AND (tfp_nextchar='^') DOπ BEGINπ Tfp_skip(p);ππ exponent:=Tfp_eval_factor(p);ππ base:=value;π IF (tfp_ernr=0) AND (base=0)π THEN value:=0π ELSEπ BEGINππ {----Over/Underflow Protected}π dummy:=exponent*Ln(Abs(base));π IF (dummy<=Ln(tfp_maxreal))π THEN value:=Exp(dummy)π ELSE Tfp_seternr(11);π END;ππ IF (tfp_ernr=0) AND (base<0)π THENπ BEGINπ {----Allow only whole number exponents,π others will result in complex numbers}π IF (Int(exponent)<>exponent)π THEN Tfp_seternr(4);ππ IF (tfp_ernr=0) AND Odd(Tfp_round(exponent))π THEN value:=-value;π END;π END;π END;ππ IF (tfp_ernr=0)π THEN Tfp_eval_term:=valueπ ELSE Tfp_eval_term:=0;ππEND; {of Tfp_Eval_term}ππ{---------------------------------------------------------}π{----Subterm = Term * Term }π{ Term / Term }π{---------------------------------------------------------}ππFUNCTION Tfp_eval_subterm(p : tfp_state_ptr) : REAL;ππVARπ value,π dummy : REAL;ππBEGINπ WITH p^ DOπ BEGINπ value:=Tfp_eval_term(p);ππ WHILE (tfp_ernr=0) AND (tfp_nextchar IN ['*','/']) DOπ CASE tfp_nextchar OFππ {----Over/Underflow Protected}π '*' : BEGINπ Tfp_skip(p);ππ dummy:=Tfp_eval_term(p);ππ IF (tfp_ernr<>0) ORπ (value=0) ORπ (dummy=0)π THEN value:=0π ELSEπ IF (Abs( Ln(Abs(value)) +π Ln(Abs(dummy)) ) < Ln(tfp_maxreal))π THEN value:= value * dummyπ ELSE Tfp_seternr(11);π END;ππ {----Over/Underflow Protected}π '/' : BEGINπ Tfp_skip(p);ππ dummy:=Tfp_eval_term(p);ππ IF (tfp_ernr=0)π THENπ BEGINππ {----Division by ZERO Protected}π IF (dummy<>0)π THENπ BEGINππ {----Underflow Protected}π IF (value<>0)π THENπ BEGINπ IF (Abs( Ln(Abs(value)) -π Ln(Abs(dummy)) ) < Ln(tfp_maxreal))π THEN value:=value/dummyπ ELSE Tfp_seternr(11)π ENDπ ELSE value:=0;π ENDπ ELSE Tfp_seternr(9);π END;π END;π END;π END;ππ IF (tfp_ernr=0)π THEN Tfp_eval_subterm:=valueπ ELSE Tfp_eval_subterm:=0;πEND;{of Tfp_Eval_subterm}ππ{---------------------------------------------------------}π{ Real Expr = Subterm + Subterm }π{ Subterm - Subterm }π{---------------------------------------------------------}ππFUNCTION Tfp_eval_r_expr(p : tfp_state_ptr) : REAL;ππVARπ dummy,π dummy2,π value : REAL;ππBEGINπ WITH p^ DOπ BEGINπ value:=Tfp_eval_subterm(p);ππ WHILE (tfp_ernr=0) AND (tfp_nextchar IN ['+','-']) DOπ CASE tfp_nextchar OFππ '+' : BEGINπ Tfp_skip(p);ππ dummy:=Tfp_eval_subterm(p);ππ IF (tfp_ernr=0)π THENπ BEGINππ {----Overflow Protected}π IF (Abs( (value/10) + (dummy/10) ) < (tfp_maxreal/10))π THEN value:=value+dummyπ ELSE Tfp_seternr(11);π END;π END;ππ '-' : BEGINπ Tfp_skip(p);π dummy2:=value;ππ dummy:=Tfp_eval_subterm(p);ππ IF (tfp_ernr=0)π THENπ BEGINππ {----Overflow Protected}π IF (Abs( (value/10) - (dummy/10) )<(tfp_maxreal/10))π THEN value:=value-dummyπ ELSE Tfp_seternr(11);ππ {----Underflow Protected}π IF (value=0) AND (dummy<>dummy2)π THEN Tfp_seternr(11);π END;π END;π END;ππ {----at this point the current char must be }π { 1. the eoln marker or }π { 2. a right bracket }π { 3. start of a boolean operator }ππ IF NOT (tfp_nextchar IN [#00,')','>','<','=',','])π THEN Tfp_seternr(2);π END;ππ IF (tfp_ernr=0)π THEN Tfp_eval_r_expr:=valueπ ELSE Tfp_eval_r_expr:=0;πEND; {of Tfp_Eval_R_Expr}ππ{---------------------------------------------------------}π{ Boolean Expr = R_Expr < R_Expr }π{ R_Expr <= R_Expr }π{ R_Expr <> R_Expr }π{ R_Expr = R_Expr }π{ R_Expr >= R_Expr }π{ R_Expr > R_Expr }π{---------------------------------------------------------}ππFUNCTION Tfp_eval_b_expr(p : tfp_state_ptr) : REAL;ππVARπ value : REAL;ππBEGINπ WITH p^ DOπ BEGINπ value:=Tfp_eval_r_expr(p);ππ IF (tfp_ernr=0) AND (tfp_nextchar IN ['<','>','=']) THENπ CASE tfp_nextchar OFππ '<' : BEGINπ Tfp_skip(p);π IF (tfp_nextchar IN ['>','='])π THENπ CASE tfp_nextchar OFπ '>' : BEGINπ Tfp_skip(p);π IF (value<>Tfp_eval_r_expr(p))π THEN value:=tfp_trueπ ELSE value:=tfp_false;π END;ππ '=' : BEGINπ Tfp_skip(p);π IF (value<=Tfp_eval_r_expr(p))π THEN value:=tfp_trueπ ELSE value:=tfp_false;π END;π ENDπ ELSEπ BEGINπ IF (value<Tfp_eval_r_expr(p))π THEN value:=tfp_trueπ ELSE value:=tfp_false;π END;π END;ππ '>' : BEGINπ Tfp_skip(p);π IF (tfp_nextchar='=')π THENπ BEGINπ Tfp_skip(p);π IF (value>=Tfp_eval_r_expr(p))π THEN value:=tfp_trueπ ELSE value:=tfp_false;π ENDπ ELSEπ BEGINπ IF (value>Tfp_eval_r_expr(p))π THEN value:=tfp_trueπ ELSE value:=tfp_false;π END;π END;ππ '=' : BEGINπ Tfp_skip(p);π IF (value=Tfp_eval_r_expr(p))π THEN value:=tfp_trueπ ELSE value:=tfp_false;π END;π END;π END;ππ IF (tfp_ernr=0)π THEN Tfp_eval_b_expr:=valueπ ELSE Tfp_eval_b_expr:=0.0;πEND; {of Tfp_Eval_B_Expr}ππ{---------------------------------------------------------}ππFUNCTION Tfp_parse2real(s : STRING): REAL;ππVARπ value : REAL;ππBEGINπ tfp_erpos:=0;π tfp_ernr :=0;ππ IF Maxavail>=Sizeof(tfp_parse_state)π THENπ BEGINπ New(p);π Tfp_check(s,p);ππ IF (tfp_ernr=0)π THEN value:=Tfp_eval_b_expr(p);ππ Dispose(p);π ENDπ ELSE Tfp_seternr(15);ππ IF (tfp_ernr<>0)π THEN Tfp_parse2real:=0.0π ELSE Tfp_parse2real:=value;ππEND; {of Tfp_Parse2Real}ππ{---------------------------------------------------------}ππFUNCTION Tfp_parse2str(s : STRING;m,n : INTEGER) : STRING;ππVARπ r : REAL;π tmp : STRING;ππBEGINπ r:=Tfp_parse2real(s);π IF (tfp_ernr=0)π THEN Str(r:m:n,tmp)π ELSE tmp:='';π Tfp_parse2str:=tmp;πEND; {of Tfp_Parse2str}ππ{---------------------------------------------------------}ππFUNCTION Tfp_errormsg(nr : INTEGER) : STRING;ππBEGINπ CASE nr OFπ 0 : Tfp_errormsg:='Result ok'; {Error 0 }π 1 : Tfp_errormsg:='Invalid format of a number'; {Error 1 }π 2 : Tfp_errormsg:='Unkown function'; {Error 2 }π 3 : Tfp_errormsg:='( ) mismatch'; {Error 3 }π 4 : Tfp_errormsg:='Real exponent -> complex number'; {Error 4 }π 5 : Tfp_errormsg:='TAN( (2n+1)*PI/2 ) not defined'; {Error 5 }π 6 : Tfp_errormsg:='Empty string'; {Error 6 }π 7 : Tfp_errormsg:='LN(x) or LOG(x) for x<=0 -> complex number'; {Error 7 }π 8 : Tfp_errormsg:='SQRT(x) for x<0 -> complex number'; {Error 8 }π 9 : Tfp_errormsg:='Divide by zero'; {Error 9 }π 10 : Tfp_errormsg:='To many function or constants'; {Error 10}π 11 : Tfp_errormsg:='Intermediate result out of range'; {Error 11}π 12 : Tfp_errormsg:='Illegal characters in functionname'; {Error 12}π 13 : Tfp_errormsg:='Not a boolean expression'; {Error 13}π 14 : Tfp_errormsg:='Wrong number of parameters'; {Error 14}π 15 : Tfp_errormsg:='Memory problems'; {Error 15}π 16 : Tfp_errormsg:='Not enough functions or constants'; {Error 16}π 17 : Tfp_errormsg:='Csc( n*PI ) not defined'; {Error 17}π 18 : Tfp_errormsg:='Sec( (2n+1)*PI/2 ) not defined'; {Error 18}π 19 : Tfp_errormsg:='Cot( n*PI ) not defined'; {Error 19}π 20 : Tfp_errormsg:='Parameter to large'; {Error 20}π 21 : Tfp_errormsg:='Csch(0) not defined'; {Error 21}π 22 : Tfp_errormsg:='Coth(0) not defined'; {Error 22}π 23 : Tfp_errormsg:='ArcCosh(x) not defined for x<1'; {Error 23}π 24 : Tfp_errormsg:='ArcTanh(x) not defined for Abs(x)=>1'; {Error 24}π 25 : Tfp_errormsg:='Arccsch(0) not defined'; {Error 25}π 26 : Tfp_errormsg:='Arcsech(x) not defined for x<=0 or x>1'; {Error 26}π 27 : Tfp_errormsg:='Arccoth(x) not defined for Abs(x)<=1'; {Error 27}π ELSE Tfp_errormsg:='Unkown error'; {Error xx}π END;πEND; {of Tfp_ermsg}ππ{---------------------------------------------------------}ππPROCEDURE Tfp_init(no : WORD);ππBEGINπ IF (maxfie>0)π THEN Freemem(fiearr,maxfie*Sizeof(tfp_fie_typ));ππ maxfie:=0;π fiesiz:=0;ππ IF (Maxavail>=(no*Sizeof(tfp_fie_typ))) AND (no>0)π THENπ BEGINπ getmem(fiearr,no*Sizeof(tfp_fie_typ));π maxfie:=no;π ENDπ ELSE Tfp_seternr(15);πEND; {of Tfp_Init}ππ{---------------------------------------------------------}ππPROCEDURE Tfp_expand(no : WORD);ππVARπ temp : ^tfp_fieptr;ππBEGINπ IF (maxfie>0) AND (no>0)π THENπ BEGINπ IF (Maxavail>=(maxfie+no)*Sizeof(tfp_fie_typ))π THENπ BEGINπ getmem(temp,(maxfie+no)*Sizeof(tfp_fie_typ));π Move(fiearr^,temp^,maxfie*Sizeof(tfp_fie_typ));π Freemem(fiearr,maxfie*Sizeof(tfp_fie_typ));π fiearr:=POINTER(temp);π maxfie:=maxfie+no;π fiesiz:=fiesiz;π ENDπ ELSE Tfp_seternr(15)π ENDπ ELSE Tfp_init(no);πEND; {of Tfp_Expand}ππ{---------------------------------------------------------}ππPROCEDURE Tfp_keep(no : WORD);ππBEGINπ IF (maxfie<no)π THEN Tfp_seternr(16)π ELSE maxfie:=no;πEND; {of Tfp_Keep}ππ{---------------------------------------------------------}ππFUNCTION Tfp_noobj : WORD;ππBEGINπ Tfp_noobj:=maxfie;πEND; {of Tfp_Noobj}ππ{---------------------------------------------------------}ππPROCEDURE Tfp_addobj(adres : POINTER;name : tfp_fname;ftype : tfp_ftype);ππVARπ i : INTEGER;ππBEGINπ{$R-}π IF (fiesiz<maxfie)π THENπ BEGINπ Inc(fiesiz);π WITH fiearr^[fiesiz] DOπ BEGINπ tfp_faddr:=adres;π tfp_fname:=name;π FOR i:=1 TO Length(tfp_fname) DOπ IF (Upcase(tfp_fname[i]) IN ['0'..'9','_','A'..'Z'])π THEN tfp_fname[i]:=Upcase(tfp_fname[i])π ELSE Tfp_seternr(12);ππ IF (Length(tfp_fname)>0) ANDπ NOT (tfp_fname[1] IN ['A'..'Z'])π THEN Tfp_seternr(12);ππ tfp_ftype:=ftype;π ENDπ ENDπ ELSE Tfp_seternr(10);π{$R+}πEND; {of Tfp_Addobject}ππ{---------------------------------------------------------}π{----Internal Functions }π{---------------------------------------------------------}ππ{$F+}ππFUNCTION Xabs(VAR r : REAL) : REAL;ππBEGINπ Xabs:=Abs(r);πEND; {of xABS}ππ{---------------------------------------------------------}ππFUNCTION Xand(VAR lu_r;VAR n : INTEGER) : REAL;ππVARπ r : REAL;π i : INTEGER;ππBEGINπ FOR i:=0 TO n DOπ IF (tfp_rarray(lu_r)[i]<>tfp_false) ANDπ (tfp_rarray(lu_r)[i]<>tfp_true)π THENπ BEGINπ IF (tfp_ernr=0)π THEN Tfp_seternr(13);π END;ππ IF (tfp_ernr=0) AND (n>0)π THENπ BEGINπ r:=tfp_true*Ord(tfp_rarray(lu_r)[0]=tfp_true);π FOR i:=1 TO n DOπ r:=tfp_true*Ord( (r=tfp_true) AND (tfp_rarray(lu_r)[i]=tfp_true))π ENDπ ELSE Tfp_seternr(14);ππ IF tfp_ernr=0π THEN Xand:=rπ ELSE Xand:=0.0;πEND; {of xAND}ππ{---------------------------------------------------------}ππFUNCTION Xarctan(VAR r : REAL) : REAL;ππBEGINπ Xarctan:=Arctan(r);πEND; {of xArctan}ππ{---------------------------------------------------------}ππFUNCTION Xcos(VAR r : REAL) : REAL;ππBEGINπ Xcos:=Cos(r);πEND; {of xCos}ππ{---------------------------------------------------------}ππFUNCTION Xdeg(VAR r : REAL) : REAL;ππBEGINπ Xdeg:=(r/pi)*180;πEND; {of xDEG}ππ{---------------------------------------------------------}ππFUNCTION Xe : REAL;ππBEGINπ Xe:=Exp(1);πEND; {of xE}ππ{---------------------------------------------------------}ππFUNCTION Xexp(VAR r : REAL) : REAL;ππBEGINπ Xexp:=0;π IF (Abs(r)<Ln(tfp_maxreal))π THEN Xexp:=Exp(r)π ELSE Tfp_seternr(11);πEND; {of xExp}ππ{---------------------------------------------------------}ππFUNCTION Xfalse : REAL;ππBEGINπ Xfalse:=tfp_false;πEND; {of xFalse}ππ{---------------------------------------------------------}ππFUNCTION Xfrac(VAR r : REAL) : REAL;ππBEGINπ Xfrac:=Frac(r);πEND; {of xFrac}ππ{---------------------------------------------------------}ππFUNCTION Xint(VAR r : REAL) : REAL;ππBEGINπ Xint:=Int(r);πEND; {of xInt}ππ{---------------------------------------------------------}ππFUNCTION Xln(VAR r : REAL) : REAL;ππBEGINπ Xln:=0;π IF (r>0)π THEN Xln:=Ln(r)π ELSE Tfp_seternr(7);πEND; {of xLn}ππ{---------------------------------------------------------}ππFUNCTION Xlog(VAR r : REAL) : REAL;ππBEGINπ Xlog:=0;π IF (r>0)π THEN Xlog:=Ln(r)/ln(10)π ELSE Tfp_seternr(7);πEND; {of xLog}ππ{---------------------------------------------------------}ππFUNCTION Xmax(VAR lu_r;VAR n : INTEGER) : REAL;ππVARπ max : REAL;π i : INTEGER;ππBEGINπ max:=tfp_rarray(lu_r)[0];π FOR i:=1 TO n DOπ IF (tfp_rarray(lu_r)[i]>max)π THEN max:=tfp_rarray(lu_r)[i];π Xmax:=max;πEND; {of xMax}ππ{---------------------------------------------------------}ππFUNCTION Xmin(VAR lu_r;VAR n : INTEGER) : REAL;ππVARπ min : REAL;π i : INTEGER;ππBEGINπ min:=tfp_rarray(lu_r)[0];π FOR i:=1 TO n DOπ IF (tfp_rarray(lu_r)[i]<min)π THEN min:=tfp_rarray(lu_r)[i];π Xmin:=min;πEND; {of xMin}ππ{---------------------------------------------------------}ππFUNCTION Xior(VAR lu_r;VAR n : INTEGER) : REAL;ππVARπ r : REAL;π i : INTEGER;ππBEGINπ FOR i:=0 TO n DOπ IF (tfp_rarray(lu_r)[i]<>tfp_false) ANDπ (tfp_rarray(lu_r)[i]<>tfp_true)π THENπ BEGINπ IF (tfp_ernr=0)π THEN Tfp_seternr(13);π END;ππ IF (tfp_ernr=0) ANDπ (n>0)π THENπ BEGINπ r:=tfp_true*Ord(tfp_rarray(lu_r)[0]=tfp_true);π FOR i:=1 TO n DOπ r:=tfp_true*Ord((r=tfp_true) OR (tfp_rarray(lu_r)[i]=tfp_true))π ENDπ ELSE Tfp_seternr(14);ππ IF tfp_ernr=0π THEN Xior:=rπ ELSE Xior:=Tfp_false;πEND; {of xIor}ππ{---------------------------------------------------------}ππFUNCTION Xpi : REAL;ππBEGINπ Xpi:=Pi;πEND; {of xPi}ππ{---------------------------------------------------------}ππFUNCTION Xrad(VAR r : REAL) : REAL;ππBEGINπ Xrad:=(r/180)*Pi;πEND; {of xRad}ππ{---------------------------------------------------------}ππFUNCTION Xround(VAR r : REAL) : REAL;ππBEGINπ IF (Abs(r)<tfp_maxlongint)π THEN Xround:=Tfp_round(r)π ELSE Xround:=r;πEND; {of xRound}ππ{---------------------------------------------------------}ππFUNCTION Xsgn(VAR r : REAL) : REAL;ππBEGINπ IF (r>=0)π THEN Xsgn:=+1π ELSE Xsgn:=-1;πEND; {of xSgn}ππ{---------------------------------------------------------}ππFUNCTION Xsin(VAR r : REAL) : REAL;ππBEGINπ Xsin:=Sin(r);πEND; {of xSin}ππ{---------------------------------------------------------}ππFUNCTION Xsqr(VAR r : REAL) : REAL;ππBEGINπ Xsqr:=0;π IF (Abs(r)>0)π THENπ BEGINπ IF ( Abs(2*Ln(Abs(r))) )<Ln(tfp_maxreal)π THEN Xsqr:=Exp( 2*Ln(Abs(r)) )π ELSE Tfp_seternr(11);π END;πEND; {of xSqr}ππ{---------------------------------------------------------}ππFUNCTION Xsqrt(VAR r : REAL) : REAL;ππBEGINπ Xsqrt:=0;π IF (r>=0)π THEN Xsqrt:=Sqrt(r)π ELSE Tfp_seternr(8);πEND; {of xSqrt}ππ{---------------------------------------------------------}ππFUNCTION Xtan(VAR r : REAL) : REAL;ππBEGINπ Xtan:=0;π IF (Cos(r)=0)π THEN Tfp_seternr(5)π ELSE Xtan:=Sin(r)/cos(r);πEND; {of xTan}ππ{---------------------------------------------------------}ππFUNCTION Xtrue : REAL;ππBEGINπ Xtrue:=tfp_true;πEND; {of xTrue}ππ{---------------------------------------------------------}ππFUNCTION Xxor(VAR r1,r2 : REAL) : REAL;ππBEGINπ Xxor:=tfp_false;π IF ((r1<>tfp_false) AND (r1<>tfp_true)) ORπ ((r2<>tfp_false) AND (r2<>tfp_true))π THENπ BEGINπ IF (tfp_ernr=0)π THEN Tfp_seternr(13);π ENDπ ELSE Xxor:=tfp_true*Ord((r1=tfp_true) XOR (r2=tfp_true));πEND; {of xXOR}ππ{---------------------------------------------------------}π{----Hyperbolic, reciproce and inverse goniometric }π{ functions }π{---------------------------------------------------------}ππFunction xCsc(VAR r: Real): Real;ππBegin;π xCsc:=0;π IF (Sin(r)=0)π THEN Tfp_seternr(17)π ELSE xCsc:=1/Sin(r);πEnd; {xCsc}ππ{---------------------------------------------------------}ππFunction xSec(VAR r: Real): Real;ππBegin;π xSec:=0;π IF (Cos(r)=0)π THEN Tfp_seternr(18)π ELSE xSec:=1/Cos(r);πEnd; {xSec}ππ{---------------------------------------------------------}ππFunction xCot(VAR r : Real): Real;ππBegin;π xCot:=0;π IF (Sin(r)=0)π THEN Tfp_seternr(19)π ELSE xCot:=Cos(r)/Sin(r);πEnd; {xCot}ππ{---------------------------------------------------------}ππFUNCTION xCosh(VAR r : REAL) : REAL;ππBEGINπ xCosh:=0;π IF (Abs(r)>Ln(tfp_maxreal))π THEN Tfp_seternr(20)π ELSE xCosh:=(Exp(r)+Exp(-r))/2;πEND; {of xCosh}ππ{---------------------------------------------------------}ππFUNCTION xSinh(VAR r : REAL) : REAL;ππBEGINπ xSinh:=0;π IF (Abs(r)>Ln(tfp_maxreal))π THEN Tfp_seternr(20)π ELSE xSinh:=(Exp(r)-Exp(-r))/2;πEND; {of xSinh}ππ{---------------------------------------------------------}ππFUNCTION xTanh(VAR r : REAL) : REAL;ππBEGINπ xTanh:=0;π IF (Abs(r)>Ln(tfp_maxreal))π THEN Tfp_seternr(20)π ELSE xTanh:=(Exp(r)-Exp(-r))/(Exp(r)+Exp(-r));πEND; {of xTanh}ππ{---------------------------------------------------------}ππFUNCTION xCsch(VAR r : REAL) : REAL;ππBEGINπ xCsch:=0;π IF (Abs(r)>Ln(tfp_maxreal))π THEN Tfp_seternr(20)π ELSEπ BEGINπ IF (r=0)π THEN Tfp_seternr(21)π ELSE xCsch:=2/(Exp(r)-Exp(-r))π END;πEND; {of xCsch}ππ{---------------------------------------------------------}ππFUNCTION xSech(VAR r : REAL) : REAL;ππBEGINπ xSech:=0;π IF (Abs(r)>Ln(tfp_maxreal))π THEN Tfp_seternr(20)π ELSE xSech:=2/(Exp(r)+Exp(-r));πEND; {of xSech}ππ{---------------------------------------------------------}ππFUNCTION xCoth(VAR r : REAL) : REAL;ππBEGINπ xCoth:=0;π IF (Abs(r)>Ln(tfp_maxreal))π THEN Tfp_seternr(20)π ELSEπ BEGINπ IF (r=0)π THEN Tfp_seternr(22)π ELSE xCoth:=(Exp(r)+Exp(-r))/(Exp(r)-Exp(-r))π END;πEND; {of xCoth}ππ{---------------------------------------------------------}ππFUNCTION xArcsinh(VAR r : REAL) : REAL;ππBEGINπ xArcsinh:=0;π IF (Abs(r)<SQRT(tfp_maxreal))π THEN xArcsinh:=Ln(r+Sqrt(Sqr(r)+1))π ELSE Tfp_seternr(20)πEND; {of xArcsinh}ππ{---------------------------------------------------------}ππFUNCTION xArccosh(VAR r : REAL) : REAL;ππBEGINπ xArccosh:=0;π IF (Abs(r)<SQRT(tfp_maxreal))π THENπ BEGINπ IF (r>=1)π THEN xArccosh:=ln(r+Sqrt(Sqr(r)-1))π ELSE Tfp_seternr(23);π ENDπ ELSE Tfp_seternr(20)πEND; {of xArccosh}ππ{---------------------------------------------------------}ππFUNCTION xArctanh(VAR r : REAL) : REAL;ππBEGINπ xArctanh:=0;π IF (Abs(r)<1)π THEN xArctanh:=ln( (1+r)/(1-r) )/2π ELSE Tfp_seternr(24)πEND; {of xArctanh}ππ{---------------------------------------------------------}ππFUNCTION xArccsch(VAR r : REAL) : REAL;ππBEGINπ xArccsch:=0;π IF (r<SQRT(Tfp_maxreal))π THENπ BEGINπ IF (r<>0)π THEN xArccsch:=Ln( (1/r) + SQRT( (1/SQR(r))+1))π ELSE Tfp_seternr(25)π ENDπ ELSE Tfp_seternr(20);πEND; {of xArccsch}ππ{---------------------------------------------------------}ππFUNCTION xArcsech(VAR r : REAL) : REAL;ππBEGINπ xArcsech:=0;π IF (r<SQRT(Tfp_maxreal))π THENπ BEGINπ IF (r>0) AND (r<=1)π THEN xArcsech:=Ln( (1/r) + SQRT( (1/SQR(r))-1))π ELSE Tfp_seternr(26)π ENDπ ELSE Tfp_seternr(20)πEND; {of xArcsech}ππ{---------------------------------------------------------}ππFUNCTION xArccoth(VAR r : REAL) : REAL;ππBEGINπ xArccoth:=0;π IF (Abs(r)>1)π THEN xArccoth:=Ln( (r+1)/(r-1) )/2π ELSE Tfp_seternr(27)πEND; {of xArccoth}ππ{$F-}ππ{---------------------------------------------------------}ππPROCEDURE Tfp_addgonio;ππBEGINπ Tfp_expand(7);π Tfp_addobj(@xarctan,'ARCTAN',tfp_1real);π Tfp_addobj(@xcos ,'COS' ,tfp_1real);π Tfp_addobj(@xdeg ,'DEG' ,tfp_1real);π Tfp_addobj(@xpi ,'PI' ,tfp_noparm);π Tfp_addobj(@xrad ,'RAD' ,tfp_1real);π Tfp_addobj(@xsin ,'SIN' ,tfp_1real);π Tfp_addobj(@xtan ,'TAN' ,tfp_1real);πEND; {of Tfp_Addgonio}ππ{---------------------------------------------------------}ππPROCEDURE Tfp_addlogic;ππBEGINπ Tfp_expand(5);π Tfp_addobj(@xand ,'AND' ,tfp_nreal);π Tfp_addobj(@xfalse ,'FALSE' ,tfp_noparm);π Tfp_addobj(@xior ,'OR' ,tfp_nreal);π Tfp_addobj(@xtrue ,'TRUE' ,tfp_noparm);π Tfp_addobj(@xxor ,'XOR' ,tfp_2real);πEND; {of Tfp_Addlogic}ππ{---------------------------------------------------------}ππPROCEDURE Tfp_addmath;ππBEGINπ Tfp_expand(7);π Tfp_addobj(@xabs ,'ABS' ,tfp_1real);π Tfp_addobj(@xexp ,'EXP' ,tfp_1real);π Tfp_addobj(@xe ,'E' ,tfp_noparm);π Tfp_addobj(@xln ,'LN' ,tfp_1real);π Tfp_addobj(@xlog ,'LOG' ,tfp_1real);π Tfp_addobj(@xsqr ,'SQR' ,tfp_1real);π Tfp_addobj(@xsqrt ,'SQRT' ,tfp_1real);πEND; {of Tfp_Addmath}ππ{---------------------------------------------------------}ππPROCEDURE Tfp_addmisc;ππBEGINπ Tfp_expand(6);π Tfp_addobj(@xfrac ,'FRAC' ,tfp_1real);π Tfp_addobj(@xint ,'INT' ,tfp_1real);π Tfp_addobj(@xmax ,'MAX' ,tfp_nreal);π Tfp_addobj(@xmin ,'MIN' ,tfp_nreal);π Tfp_addobj(@xround ,'ROUND' ,tfp_1real);π Tfp_addobj(@xsgn ,'SGN' ,tfp_1real);πEND; {of Tfp_Addmisc}ππ{---------------------------------------------------------}ππPROCEDURE Tfp_addinvarchyper;ππBEGINπ Tfp_expand(15);π Tfp_addobj(@xcsc ,'CSC' ,tfp_1real);π Tfp_addobj(@xsec ,'SEC' ,tfp_1real);π Tfp_addobj(@xcot ,'COT' ,tfp_1real);ππ Tfp_addobj(@xsinh ,'SINH' ,tfp_1real);π Tfp_addobj(@xcosh ,'COSH' ,tfp_1real);π Tfp_addobj(@xtanh ,'TANH' ,tfp_1real);ππ Tfp_addobj(@xcsch ,'CSCH' ,tfp_1real);π Tfp_addobj(@xsech ,'SECH' ,tfp_1real);π Tfp_addobj(@xcoth ,'COTH' ,tfp_1real);ππ Tfp_addobj(@xarcsinh,'ARCSINH',tfp_1real);π Tfp_addobj(@xarccosh,'ARCCOSH',tfp_1real);π Tfp_addobj(@xarctanh,'ARCTANH',tfp_1real);ππ Tfp_addobj(@xarccsch,'ARCCSCH',tfp_1real);π Tfp_addobj(@xarcsech,'ARCSECH',tfp_1real);π Tfp_addobj(@xarccoth,'ARCCOTH',tfp_1real);πEnd; {of Add_invandhyper}ππ{---------------------------------------------------------}ππPROCEDURE Tfp_addall;ππBEGINπ Tfp_addgonio;π Tfp_addlogic;π Tfp_addmath;π Tfp_addmisc;π Tfp_addinvarchyper;πEND; {of Tfp_addall}ππ{---------------------------------------------------------}ππBEGINπ{----Module Init}π tfp_erpos :=0;π tfp_ernr :=0;π fiesiz:=0;π maxfie:=0;π fiearr:=NIL;πEND.π 5 08-25-9409:08ALL BOB SCHOR FFT Algorithm in Pascal SWAG9408 ⌡&ª» 122 ₧ {π─ Area: U-PASCAL |61 ────────────────────────────────────────────────────π Msg#: 5727 Date: 07-05-94 08:14π From: Bschor@vms.cis.pitt.edu Read: Yes Replied: Noπ To: All Mark:π Subj: FFT Algorithm in Pascalπ──────────────────────────────────────────────────────────────────────────────πFrom: bschor@vms.cis.pitt.eduππ Over the past several weeks, there have been questions about the FastπFourier Transform, including requests for a version of the algorithm. Theπfollowing is one such implementation, optimized for clarity (??) at theπpossible expense of a few percentage points in speed (it's pretty darnπfast). It is written in "vanilla" Pascal, so it should work with allπvariants of the language.ππ Note that buried in the comments is a reasonable reference for theπalgorithm.π }πππPROGRAM fft (input, output);ππ {****************************************}π { }π { Bob Schor }π { Eye and Ear Institute }π { 203 Lothrop Street }π { Pittsburgh, PA 15213 }π { }π {****************************************}ππ { test routine for FFT in Pascal -- includes real and complex }ππ { Version 1.6 -- first incarnation }π { Version 10.7 -- upgrade, allow in-place computation of coefficients }π { Version 14.6 -- comments added for didactic purposes }π πCONSTπ version = 'FFT Version 14.6';π πCONSTπ maxarraysize = 128;π halfmaxsize = 64;π maxfreqsize = 63;πTYPEπ dataindextype = 1 .. maxarraysize;π cmpxindextype = 1 .. halfmaxsize;π freqindextype = 1 .. maxfreqsize;π complex = RECORDπ realpart, imagpart : realπ END;π dataarraytype = RECORDπ CASE (r, c) OFπ r : (rp : ARRAY [dataindextype] OF real);π c : (cp : ARRAY [cmpxindextype] OF complex)π END;π cstermtype = RECORDπ cosineterm, sineterm : realπ END;π fouriertype = RECORDπ dcterm : real;π noiseterm : real;π freqterms : ARRAY [freqindextype] OF cstermtypeπ END;π mixedtype = RECORDπ CASE (dtype, ctype) OFπ dtype : (dataslot : dataarraytype);π ctype : (coefslot : fouriertype)π END;π πCONSTπ twopi = 6.2831853;πVARπ data : dataarraytype;π didx : dataindextype;π fidx : freqindextype;π coefficients : fouriertype;π mixed : mixedtype;π π { A note on declarations, above. Pascal does not have a base type ofπ "complex", but it is fairly simple, given the strong typing in theπ language, to define such a type. One needs to write procedures (seeπ below) that implement the common arithmetic operators. Functionsπ would be even better, from a logical standpoint, but the languageπ standard does not permit returning a record type from a function.π . The FFT, strictly speaking, is a technique for transforming aπ complex array of points-in-time into a complex array of points-in-π Fourier space (complex numbers that represent the gain and phase ofπ the response at discrete frequencies). One typically has data,π representing samples taken at some fixed sampling rate, for whichπ one wants the Fourier transform, to compute a power spectrum, forπ example. Such data, of course, are "real" quantities. One couldπ take these N points, make them the real part of a complex array ofπ size N (setting the imaginary part to zero), and take the FFT.π However, in the interest of speed (the first F of FFT means "fast",π after all), one can also do a trick where the N "real" points areπ identified with the real, imaginary, real, imaginary, etc. points ofπ a complex array of size N/2. The FFT now takes about half the time,π and one needs to do some final twiddling to obtain the sine/cosineπ coefficients of the size N real array from the coefficients of theπ size N/2 complex array.π . To clarify the dual interpretation of the data array as eitherπ N reals or N/2 complex points, the tagged type "dataarraytype" wasπ defined. On input, it represents the complex data; on output from theπ complex FFT, it represents the complex Fourier coefficients. A finalπ transformation on these complex coefficients can convert them into aπ series of real sine/cosine terms; for this purpose, the tagged typeπ "mixed" was defined for the real FFT.π . Finally, note that this, and most, FFT routines get theirπ speed when the number of points is a power of 2. This is becauseπ the speed comes from a divide-and-conquer approach -- to do an FFTπ of N points, do two FFTs of N/2 points and combine the results. }π π π PROCEDURE fftofreal (VAR mixed : mixedtype;π realpoints : integer);π π { This routine performs a forward Fourier transform of an arrayπ "mixed", which on input is assumed to consist of "realpoints" dataπ points and on output consists of a set of Fourier coefficients (aπ DC term, (N/2 - 1) sine and cosine terms, and a residual "noise"π term). }π π CONSTπ twopi = 6.2831853;π VARπ index, minusindex : freqindextype;π temp1, temp2, temp3, w : complex;π baseangle : real;π π { The following procedures implement complex arithmetic -- }π π PROCEDURE cadd (a, b : complex;π VAR c : complex);π π { c := a + b }π π BEGIN { cadd }π WITH c DOπ BEGINπ realpart := a.realpart + b.realpart;π imagpart := a.imagpart + b.imagpartπ ENDπ END;π π PROCEDURE csubtract (a, b : complex;π VAR c : complex);π π { c := a - b }π π BEGIN { csubtract }π WITH c DOπ BEGINπ realpart := a.realpart - b.realpart;π imagpart := a.imagpart - b.imagpartπ ENDπ END;π π PROCEDURE cmultiply (a, b : complex;π VAR c : complex);ππ { c := a * b }π π BEGIN { cmultiply }π WITH c DOπ BEGINπ realpart := a.realpart*b.realpart - a.imagpart*b.imagpart;π imagpart := a.realpart*b.imagpart + b.realpart*a.imagpartπ ENDπ END;π π PROCEDURE conjugate (a : complex;π VAR b : complex);π π { b := a* }π π BEGIN { conjugate }π WITH b DOπ BEGINπ realpart := a.realpart;π imagpart := -a.imagpartπ ENDπ END;π π PROCEDURE forwardfft (VAR data : dataarraytype;π complexpoints : integer);π ππ { The basic FFT is a recursive routine that basically works asπ follows:π 1) The FFT is a linear operator, so the FFT of a sum is simplyπ . the sum of the FFTs of each addend.π 2) The FFT of a time series shifted in time is the FFT of theπ . unshifted series adjusted by a twiddle factor which looksπ . like a (complex) root of 1 (an nth root of unity).π 3) Consider N points, equally spaced in time, for which youπ . want an FFT. Start by splitting the series into odd andπ . even samples, giving you two series with N/2 points,π . equally spaced, but with the second series delayed in timeπ . by one sample. Take the FFT of each series. Using propertyπ . 2), adjust the FFT of the second series for the time delay.π . Now using property 1), since the original N points is simplyπ . the sum of the two N/2 series, the FFT we want is simply theπ . sum of the FFTs of the two sub-series (with the adjustmentπ . in the second for the time delay).π 4) This is essentially a recursive definition. To do an N-pointπ . FFT, do two N/2 point FFTs and combine the answers. All weπ . need to stop the recursion is to know how to do a 2-pointπ . FFT: if a and b are the two (complex) input points, theπ . two-point FFT equations are A := a+b; B := a-b.π 5) The FFT is rarely coded in its fully-recursive form. Itπ . turns out to be fairly simple to "unroll" the recursion andπ . reorder it a bit, which simplifies the computation of theπ . roots-of-unity complex twiddle factors. The only drawbackπ . is that the output array ends up scrambled -- if the arrayπ . indices are represented as going from 0 to M-1, then if oneπ . represents the array index as a binary number, one needs toπ . bit-reverse the number to get the proper place in the array.π . Thus, the next step is to swap values by bit-reversing theπ . indices.π 6) There are numerous references on the FFT. A reasonable oneπ . is "Numerical Recipes" by Press et al., Cambridge Universityπ . Press, which I believe exists in several language flavors. }π π CONSTπ twopi = 6.2831853;π π PROCEDURE docomplextransform;π π VARπ partitionsize, halfsize, offset,π lowindex, highindex : dataindextype;π baseangle, angle : real;π bits : integer;π w, temp : complex;π π BEGIN { docomplextransform }π partitionsize := complexpoints;π WITH data DOπ REPEATπ halfsize := partitionsize DIV 2;π baseangle := twopi/partitionsize;π FOR offset := 1 TO halfsize DOπ BEGINπ angle := baseangle * pred(offset);π w.realpart := cos(angle);π w.imagpart := -sin(angle);π lowindex := offset;π REPEATπ highindex := lowindex + halfsize;π csubtract (cp[lowindex], cp[highindex], temp);π cadd (cp[lowindex], cp[highindex], cp[lowindex]);π cmultiply (temp, w, cp[highindex]);π lowindex := lowindex + partitionsizeπ UNTIL lowindex >= complexpointsπ END;π partitionsize := partitionsize DIV 2π UNTIL partitionsize = 1π END;π π PROCEDURE shufflecoefficients;π π VARπ lowindex, highindex : dataindextype;π bits : integer;π π FUNCTION log2 (index : integer) : integer;π π { Recursive routine, where "index" is assumed a power of 2.π Note the routine will fail (by endless recursion) ifπ "index" <= 0. }π π BEGIN { log2 }π IF index = 1π THEN log2 := 0π ELSE log2 := succ(log2(index DIV 2))π END;ππ FUNCTION bitreversal (index, bits : integer) : integer;π π { Takes an index, in the range 1 .. 2**bits, and computes aπ bit-reversed index in the same range. It first undoes theπ offset of 1, bit-reverses the "bits"-bit binary number,π then redoes the offset. Thus if bits = 4, the range isπ 1 .. 16, and bitreversal (1, 4) = 9,π bitreversal (16, 4) = 16, etc. }π π FUNCTION reverse (bits, stib, bitsleft : integer) : integer;ππ { Recursive bit-reversing function, transforms "bits" intoπ bit-reversed "stib. It's pretty easy to convert this toπ an iterative form, but I think the recursive form isπ easier to understand, and should entail a trivial penaltyπ in speed (in the overall algorithm). }π π BEGIN { reverse }π IF bitsleft = 0π THEN reverse := stibπ ELSEπ IF odd (bits)π THEN reverse := reverse (bits DIV 2, succ (stib * 2),π pred (bitsleft))π ELSE reverse := reverse (bits DIV 2, stib * 2,π pred (bitsleft))π END;ππ BEGIN { bitreversal }π bitreversal := succ (reverse (pred(index), 0, bits))π END;π π PROCEDURE swap (VAR a, b : complex);π π VARπ temp : complex;π π BEGIN { swap }π temp := a;π a := b;π b := tempπ END;π π BEGIN { shufflecoefficients }π bits := log2 (complexpoints);π WITH data DOπ FOR lowindex := 1 TO complexpoints DOπ BEGINπ highindex := bitreversal(lowindex, bits);π IF highindex > lowindexπ THEN swap (cp[lowindex], cp[highindex])π ENDπ END;π π PROCEDURE dividebyn;ππ { This procedure is needed to get FFT to scale correctly. }π π VARπ index : dataindextype;π π BEGIN { dividebyn }π WITH data DOπ FOR index := 1 TO complexpoints DOπ WITH cp[index] DOπ BEGINπ realpart := realpart/complexpoints;π imagpart := imagpart/complexpointsππ ENDπ END;π π BEGIN { forwardfft }π docomplextransform;π shufflecoefficients;π dividebynπ END;π π { Note that the data slots and coefficient slots in the mixedπ data type share storage. From the first complex coefficient,π we can derive the DC and noise term; from pairs of the remainingπ coefficients, we can derive pairs of sine/cosine terms. }π π π BEGIN { fftofreal }π forwardfft (mixed.dataslot, realpoints DIV 2);π temp1 := mixed.dataslot.cp[1];π WITH mixed.coefslot, temp1 DOπ BEGINπ dcterm := (realpart + imagpart)/2;π noiseterm := (realpart - imagpart)/2π END;π baseangle := -twopi/realpoints;π FOR index := 1 TO realpoints DIV 4 DOπ BEGINπ minusindex := (realpoints DIV 2) - index;π WITH mixed.dataslot DOπ BEGINπ conjugate (cp[succ(minusindex)], temp2);π cadd (cp[succ(index)], temp2, temp1);π csubtract (cp[succ(index)], temp2, temp2)π END;π w.realpart := sin(index*baseangle);π w.imagpart := -cos(index*baseangle);π cmultiply (w, temp2, temp2);π cadd (temp1, temp2, temp3);π csubtract (temp1, temp2, temp2);π conjugate (temp2, temp2);π WITH mixed.coefslot.freqterms[index], temp3 DOπ BEGINπ cosineterm := realpart/2;π sineterm := -imagpart/2π END;π WITH mixed.coefslot.freqterms[minusindex], temp2 DOπ BEGINπ cosineterm := realpart/2;π sineterm := imagpart/2π ENDπ ENDπ END;π π FUNCTION omegat (f : freqindextype; t : dataindextype) : real;π π { computes omega*t for particular harmonic, index }ππ BEGIN { omegat }π omegat := twopi * f * pred(t) / maxarraysizeπ END;π π { main test routine starts here }π π BEGINπ WITH mixed.dataslot DOπ FOR didx := 1 TO maxarraysize DOπ rp[didx] := (23π + 13 * sin(omegat (7, didx))π + 28 * cos(omegat (22, didx)));π fftofreal (mixed, maxarraysize);π WITH mixed.coefslot DOπ writeln ('DC = ', dcterm:10:2, ' ':5, 'Noise = ', noiseterm:10:2);π FOR fidx := 1 TO maxfreqsize DOπ BEGINπ WITH mixed.coefslot.freqterms[fidx] DOπ write (fidx:4, round(cosineterm):4, round(sineterm):4, ' ':4);π IF fidx MOD 4 = 0π THEN writelnπ END;π writeln;π writeln ('The expected result should have been:');π writeln (' DC = 23, noise = 0, ');π writeln (' sine 7th harmonic = 13, cosine 22nd harmonic = 28')π END.π 6 08-25-9409:08ALL MARCEL HOOGEVEEN FFT algorithm SWAG9408 +╥╕ 19 ₧ {πFrom: marcel.hoogeveen@hacom.wlink.nl (Marcel Hoogeveen)ππGR> FFT stands for Fast Fourier Transform. It is a quick way to converπGR> time domain data (ie oscilliscopy data with time on the x-axis) toπGR> frequency domain (frequency on the x-axis, like a frequency spectrumπGR> analyzer). This is a usefull data analysis method. I would also likeπGR> to get some source for this.πππThis is what i have of FFT source code, it should work if you tweak it a bit.π(It did for me when i used it in my analasis program).πDon't ask me how it works, i know how a DFT works but a FFT well .. just useπthe source. :)ππ}πProgram FFT;πConst Twopi=6.283185303;ππType Curve=array[1..nfft] of real;ππVar {This is for you to find out}ππ{ Calculation of the Discrete Fourier Transfor }π{ Using a Fast Fourier Transform algorithm }π{ }π{ XR and XI are array of reals !!! }π{ They contain on entry the input sequence and }π{ on return the transfrom }π{ ISI defines the transform direction }π{ If ISI=-1 then forward, if ISI=1 then invert }π{ }π{ The dimension is 2**M }ππProcedure RFFT (VAR XR,XI:Curve; N:integer; ISI:Integer);πVarπM,NV2,LE,LE1,IP,I,J,K,L: Integer;πC,THETA,UR,UI,TR,TI:Real;ππBeginπM:=Round(LN(N)/LN(2));πNV2:= N DIV 2;πJ:=1;πFor I:= 1 to N-1 doπBeginπIf (I<J) thenπBeginπTR:=XR[J]; TI:=X[J];πXR[J]:=XR[I]; XI[J]:=XI[I];πXR[I]:=TR; XI[I]:=TI;πEnd;πK:=NV2;πWhile (K<J) doπBeginπJ:=J-K;πK:=K DIV 2;πEnd;πJ:=J+K;πEnd;πLE:=1;πC:=ISI*TWOPI;πFor L:=1 TO M doπBeginπLE1:=LE;πLE:=LE*2;πFor J:=1 TO LE1 doπBeginπTHETA:= C*(J-1)/LE;πUR:=COS(tHETA);πUI:=SIN(THETA);πI:=J;πRepeatπIP:=I+LE1;πTR:=XR[IP]*UR-XI[IP]*UI;πTI:+XR[IP]*UI+XI[IP]*UR;πXR[IP]:=XR[I]-TR; XI[IP]:=XI[I]-TP;πXR[I]:=XR[I]+TR; XI[I]:=XI[I]+TI;πI:=I+LE;πUntil (I>=N)πEnd;πEnd;πIf ISI=-1 thenπBeginπFor I:= 1 TO N doπBeginπXR[I]:=4*XR[I]/N; XI[I]:=4*XI[I]/N;πEnd;πEnd;πEnd;πππBeginπFor I := 1 to NUMSAM doπBeginπFREAL[I]:=SAMPLEBUFFER[I];πFIMAG[I]:=0;πEnd;πRFFT(FREAL,FIMAG,NUMSAM,-1);πDC:=FREAL[1]/2;πFor I:= 1 to NUMSAM dOπFREAL[I]:=FREAL[I]*FREAL[I]+fIMAG[I]*FIMAG[I];πEnd.π 7 08-25-9409:08ALL RANDALL ELTON DING Random Gaussian VariablesSWAG9408 òe┼ 24 ₧ (*πFrom: randyd@alpha2.csd.uwm.edu (Randall Elton Ding)ππ>I a program I'm currently struggeling with, I need to get a random numberπ>from a Gaussian distribution. Anybody got any ideas or anybody able to pointπ>to something which does the job.ππThis does a pretty good job of generating a gaussian random variableπwith mean `a` and standard deviation `d`.πThis program also does a graphic plot to demonstrate the function.ππFirst, here is the origional C source if the gaussian functionπwhich I transcribed to beloved pascal..ππ/* ------------------------------------------------ *π * gaussian -- generates a gaussian random variable *π * with mean a and standard deviation d *π * ------------------------------------------------ */π double gaussian(a,d)π double a,d;π {π static double t = 0.0;π double x,v1,v2,r;π if (t == 0) {π do {π v1 = 2.0 * rnd() - 1.0;π v2 = 2.0 * rnd() - 1.0;π r = v1 * v1 + v2 * v2;π } while (r>=1.0);π r = sqrt((-2.0*log(r))/r);π t = v2*r;π return(a+v1*r*d);π }π else {π x = t;π t = 0.0;π return(a+x*d);π }π }πππ* ----------------------------------------------------------------------π* now, the same thing in pascalπ* ----------------------------------------------------------------------π*)ππ{$N+}πprogram testgaussian;ππuses graph,crt;ππconstπ bgipath = 'e:\bp\bgi';ππprocedure initbgi;π varπ errcode,grdriver,grmode: integer;ππ beginπ grdriver:= detect;π grmode:= 0;π initgraph (grdriver,grmode,bgipath);π errcode:= graphresult;π if errcode <> grok then beginπ writeln ('Graphics error: ',grapherrormsg (errcode));π halt (1);π end;π end;ππππfunction rnd: double; { this isn't the best, but it works }π var { returns a random number between 0 and 1 }π i: integer;π r: double;ππ beginπ r:= 0;π for i:= 1 to 15 do beginπ r:= r + random(10);π r:= r/10;π end;π rnd:= r;π end;ππππfunction gaussian(a,d: double): double; { a is mean }π const { d is standard deviation }π t: double = 0; { pascal's equivalent to C's static variable }ππ varπ x,v1,v2,r: double;ππ beginπ if t=0 then beginπ repeatπ v1:= 2*rnd-1;π v2:= 2*rnd-1;π r:= v1*v1+v2*v2π until r<1;π r:= sqrt((-2*ln(r))/r);π t:= v2*r;π gaussian:= a+v1*r*d;π endπ else beginπ x:= t;π t:= 0;π gaussian:= a+x*d;π end;π end;ππππprocedure testplot;π varπ x,mx,my,y1: word;π y: array[1..999] of word;π { ^^^ make this bigger if you have incredible graphics }π beginπ initbgi;π mx:= getmaxx+1;π my:= getmaxy;π fillchar(y,sizeof(y),#0);π repeatπ x:= trunc(gaussian(mx/2,50));π y1:= y[x];π putpixel(x,my-y1,white);π y[x]:= y1+1;π until keypressed;π closegraph;π end;ππππbeginπ randomize;π testplot;πend.ππ 8 08-25-9409:09ALL MARTIN PREISHUBER Math Unit SWAG9408 ─u2╙ 487 ₧ {πFrom: Martin Preishuber <martin_p@efn.efn.org>ππmycalc.pas that is a unit with mathematical function. the numbersπ are based on 65536, so you can calculate with reallyπ huge numbers.πrabin.pas it's a demo program for mycalc. you can test largeπ number,s whether it is a prime or notππboth programs are documented in german, so i guess that documentationπwon't help much :-(π}ππ(* ----------------------------------------------------------------------- *)π(* RabinTest prüft, ob eine Zahl eine Primzahl ist *)π(* ----------------------------------------------------------------------- *)ππ{$M 65000, 0, 655360} (* Stack auf maximale Größe *)ππPROGRAM RabinTest;ππUSES Crt, (* Ein/Ausgabefunktionen *)π Extend, (* erweiterte I/O - Funktionen *)π MyCalc; (* Funktionen für das Rechnen mit großen Zahlen *)ππ(* ----------------------------------------------------------------------- *)ππFUNCTION Expt(zahl : Real; hoch : INTEGER) : Real;π (* Berechnung des Exponenten einer Realzahl (einfach, weil nur für die *)π (* Berechnung von AnzahlTests nötig *)πVAR i : INTEGER; (* Zählvariable *)π hilfe : Real; (* Hilfsvariable für das Ergebnis *)πBEGINπ IF hoch = 0 THEN (* Hochzahl = 0 *)π Expt := 1 (* => Ergebnis = 1 *)π ELSEπ BEGINπ hilfe := 1; (* Ergebnis mit 1 initialisieren *)π FOR i := 1 TO hoch DO hilfe := hilfe * zahl;π (* Zahl hoch mal mit sich selbst multiplizieren *)π Expt := hilfe; (* Ergebnis zurückliefern *)π END;πEND;ππ(* ----------------------------------------------------------------------- *)ππFUNCTION AnzahlTests(wahrscheinlichkeit : Real) : INTEGER;π (* ermittelt die Anzahl Tests, welche nötig sind um die gewünschte *)π (* Wahrscheinlichkeit zu erreichen *)πVAR anzahl : INTEGER; (* Anzahl der nötigen Tests *)πBEGINπ anzahl := 0; (* Anzahl mit 0 initialisieren *)π REPEATπ INC(anzahl); (* Anzahl um 1 erhöhen *)π UNTIL ((1/(Expt(4,anzahl))) < wahrscheinlichkeit);π (* solange wiederholen, bis W > (1/4)^x *)π AnzahlTests := anzahl; (* Anzahl Tests zurückgeben *)πEND;ππ(* ----------------------------------------------------------------------- *)ππFUNCTION EvenString(zahl : STRING) : BOOLEAN;π (* prüft, on ein String gerade ist *)πBEGINπ EvenString := NOT Odd(Ord(zahl[Length(zahl)]) - 48);πEND; (* prüft, ob die letzte Stelle des Strings gerade ist *)ππ(* ----------------------------------------------------------------------- *)ππFUNCTION Div5(zahl : STRING) : BOOLEAN;π (* prüft, ob ein String durch 5 dividierbar ist *)πVAR last : BYTE; (* letzte Stelle von zahl *)πBEGINπ last := Ord(zahl[Length(zahl)]) - 48; (* letzte Stelle ermitteln *)π IF (last = 0) OR (last = 5) THEN (* Falls letzte Stelle 0 oder 5 ist *)π Div5 := TRUE (* ist die Zahl durch 5 dividierbar *)π ELSEπ Div5 := FALSE; (* sonst nicht *)πEND; (* prüft, ob die letzte Stelle des Strings gerade ist *)ππ(* ----------------------------------------------------------------------- *)ππFUNCTION Div3(zahl : STRING) : BOOLEAN;π (* prüft, ob ein String durch 5 dividierbar ist *)πVAR ziffernSumme : WORD; (* Ziffernsumme des Strings *)π laenge : BYTE; (* Laenge des Strings *)π i : BYTE; (* Zählvariable *)πBEGINπ ziffernSumme := 0; (* Ziffernsumme initialisieren *)π laenge := Length(zahl); (* Länge des Strings ermitteln *)π FOR i := 1 TO laenge DO (* ZiffernSumme ermitteln *)π BEGINπ ziffernSumme := ziffernSumme + (Ord(zahl[i]) - 48);π (* aktuelle Zahl zur Ziffernsumme addieren *)π END;π IF (ZiffernSumme MOD 3) = 0 THEN (* Ziffernsumme durch 3 teilbar *)π Div3 := TRUE (* => Zahl durch 3 teilbar *)π ELSEπ Div3 := FALSE; (* sonst ist Zahl nicht durch 3 teilbar *)πEND;ππ(* ----------------------------------------------------------------------- *)π(* Bedingung 1 beim Rabintest: b^v≡1 mod p *)ππFUNCTION Bedingung1(b, v, p, pMinus1, EINS : CalcStr) : BOOLEAN;πVAR hilfe : CalcStr; (* HilfsCalcString *)πBEGINπ ExptModCalcStr(b, v, p, hilfe); (* b^v mod p berechnen *)ππ Write('b^v mod p = '); PrintCalcStr(hilfe);ππ IF EqualCalcStr(hilfe, EINS) THEN (* Falls Ergebnis = 1 *)π Bedingung1 := TRUE (* Bedingung 1 erfüllt *)π ELSEπ IF EqualCalcStr(hilfe, pMinus1) THENπ Bedingung1 := TRUE (* Bedingung 2 mit r=0 erfüllt *)π ELSEπ Bedingung1 := FALSE; (* sonst ist Bedingung 1 nicht erfüllt *)πEND;ππ(* ----------------------------------------------------------------------- *)π(* Bedingung 2 beim Rabintest: b^(v^(2r)) ≡ -1 mod p *)ππFUNCTION Bedingung2(VAR b, v, u, p, pMinus1, EINS : CalcStr) : BOOLEAN;πVAR r : CalcStr; (* zu durchlaufende Hochzahlen *)π ZWEI : CalcStr; (* konstante CalcString-Darstellung für 2 *)π hilfe1 : CalcStr; (* HilfsCalcString *)π hilfe2 : CalcStr; (* HilfsCalcString *)πBEGINπ InitCalcStr(r); (* r initialisieren *)π r.stellen := 1; (* r hat 1 Stelle, diese ist zu Beginn 0 *)π r.zahl[1] := 1; (* r läuft von 1 weg, weil Bedingung mit r=0 schon in *)π (* Bedingung 1 geprüft wird *)π WordToCalcStr(2, ZWEI); (* Zahl zwei in CalcString ermitteln *)π WHILE LessCalcStr(r, u) DO (* solange r < u *)π BEGINππ Write('r = '); PrintCalcStr(r);ππ ExptCalcStr(ZWEI, r, hilfe1); (* 2^r ermitteln *)π MulCalcStr(hilfe1, v, hilfe2); (* 2^r mit v multiplizieren *)π ExptModCalcStr(b, hilfe2, p, hilfe1); (* b^(v2^r) MOD p berechnen *)ππ Write('b^(v2^r) mod p = '); PrintCalcStr(hilfe1);ππ IF EqualCalcStr(hilfe1, pMinus1) THEN (* Falls Ergebnis = -1 *)π BEGINπ Bedingung2 := TRUE; (* Bedingung 2 erfüllt *)π EXIT;π END;π AddCalcStr(r, EINS, hilfe2); (* r um 1 erhöhen *)π r := hilfe2; (* r wieder zuweisen *)π END;π Bedingung2 := FALSE; (* 2. Bedingung nicht erfüllt *)πEND;ππ(* ----------------------------------------------------------------------- *)π(* Rabin prüft eine Zahl mit Hilfe des RabinTests *)ππFUNCTION Rabin(primzahl : STRING; anzahl : INTEGER) : BOOLEAN;πVAR p : CalcStr; (* zu untersuchende Primzahl *)π pMinus1 : CalcStr; (* Primzahl - 1 *)π EINS : CalcStr; (* konstanter Wert für 1 *)π u : CalcStr; (* p-1 = 2^u*v (v ungerade) *)π v : CalcStr; (* p-1 = 2^u*v (v ungerade) *)π b : CalcStr; (* Basis bei Primzahltest *)π hilfe : CalcStr; (* HilfsCalcString *)π i : BYTE; (* Zählvariable *)πBEGINπ StrToCalcStr(primzahl, p); (* Primzahl ins 65536-System umwandeln *)π WordToCalcStr(1, EINS); (* CalcStringdarstellung von 1 *)π SubCalcStr(p, EINS, pMinus1); (* vom pMinus1 = p - 1 *)π InitCalcStr(u); (* u initialisieren *)π u.stellen := 1; (* u besitzt 1 Stellen, diese ist 0 *)π v := pMinus1; (* v ist zu Beginn p-1 *)π REPEATπ AddCalcStr(u, EINS, hilfe); (* 2^u, Potenz um 1 erhöhen *)π u := hilfe; (* und wieder u zuweisen *)π Div2CalcStr(v); (* v durch 2 dividieren *)π UNTIL OddCalcStr(v); (* solange, bis v ungerade ist *)ππ Write('p = '); PrintCalcStr(p);π Write('u = '); PrintCalcStr(u);π Write('v = '); PrintCalcStr(v);ππ FOR i := 1 TO anzahl DO (* Anzahl Tests durchführen *)π BEGINπ RandomCalcStr(p, b); (* zufällige Basis ermitteln *)ππ Write('b = '); PrintCalcStr(b);ππ IF (Bedingung1(b, v, p, pMinus1, EINS) = FALSE) THENπ (* 1. Bedingung prüfen *)π IF (Bedingung2(b, v, u, p, pMinus1, EINS) = FALSE) THENπ BEGIN (* 2. Bedingung prüfen *)π Rabin := FALSE;π EXIT; (* beide Bedingungen nicht erfüllt => keine Primzahl *)π END;π END;π Rabin := TRUE; (* Rabintest bestanden *)πEND;ππ(* ----------------------------------------------------------------------- *)π(* PrimeTest prüft, ob Zahl eine Primzahl ist *)ππFUNCTION PrimeTest(zahl : STRING; anzahlTests : INTEGER; VAR meldung : STRING)π: BOOLEAN;πBEGINπ IF EvenString(zahl) THEN (* Zahl ist durch 2 dividierbar *)π BEGINπ PrimeTest := FALSE; (* => keine Primzahl *)π meldung := 'gerade Zahl'; (* Meldung zurückgeben *)π ENDπ ELSEπ IF Div5(zahl) THEN (* Falls Zahl durch 5 dividierbar ist *)π BEGINπ PrimeTest := FALSE; (* => keine Primzahlπ*)π meldung := 'Zahl durch 5 dividierbar'; (* Meldung zurückgeben *)π ENDπ ELSEπ IF Div3(zahl) THEN (* Zahl durch 3 dividierbar *)π BEGINπ PrimeTest := FALSE; (* => keine Primzahl *)π meldung := 'Zahl durch 3 dividierbar'; (* Meldung zurückgeben *)π ENDπ ELSEπ BEGINπ IF NOT Rabin(zahl, anzahlTests) THEN (* Falls Rabintest negativ *)π BEGINπ PrimeTest := FALSE; (* keine Primzahl *)π meldung := 'Rabintest'; (* Meldung zurückgeben *)π ENDπ ELSEπ PrimeTest := TRUE; (* sonst ist Zahl Primzahl *)π END;πEND;ππ(* ----------------------------------------------------------------------- *)π(* Hauptprogramm erledigt die Ein/Ausgabe *)ππPROCEDURE Hauptprogramm; (* Hauptprogramm des Primzahltests *)πVAR anzahl : INTEGER; (* Anzahl notwendiger Tests *)π wahrscheinlichkeit : Real; (* Fehlerwahrscheinlichkeit *)π primzahl : STRING; (* zu untersuchende Zahl *)π meldung : STRING; (* Meldung, warum keine Primzahl *)π prim : BOOLEAN; (* ist sie Primzahl oder nicht *)πBEGINπ ClrScr; (* Bildschirm löschen *)π Frame(27, 1, 53, 3, 1, '', TRUE); (* Rahmen ausgeben *)π WriteXY(29, 2, 'Primzahltest nach Rabin');π GotoXY(1, 6);π WriteLn('1. Test: gerade Zahl'); (* Tests anzeigen *)π WriteLn('2. Test: Zahl durch 5 dividierbar');π WriteLn('3. Test: Ziffernsumme durch 3 dividerbar');π WriteLn('4. Test: RabinTest');π WriteLn;π Write('Primzahl (p): '); ReadLn(primzahl); (* Primzahl eingeben *)π Write('Fehlerwahrscheinlichkeit: '); ReadLn(wahrscheinlichkeit);π (* Fehlerwahrscheinlichkeit eingeben *)π anzahl := AnzahlTests(wahrscheinlichkeit); (* Testanzahl ermitteln *)π WriteLn;π WriteLn('Anzahl Tests: ', anzahl);π WriteLn;π prim := PrimeTest(primzahl, anzahl, meldung); (* auf Primzahl testen *)π Write(primzahl, ' ist ');π IF NOT prim THENπ WriteLn('keine Primzahl (',meldung,')') (* Meldung ausgeben *)π ELSEπ WriteLn('Primzahl');πEND;ππ(* ----------------------------------------------------------------------- *)ππBEGINπ Hauptprogramm; (* Hauptprogramm aufrufen *)πEND.ππ(* ----------------------------------------------------------------------- *)ππ(* ----------------------------------------------------------------------- *)π(* MyCalc stellt eine LongInteger-Arithmetik zur Verfuegung *)π(* ----------------------------------------------------------------------- *)ππ{$M 65000, 0, 655360} (* Stack auf maximale Groesse *)ππUNIT MyCalc;ππINTERFACEππCONST MAXCALCSTR = 500; (* maximal 500 Word-Zahlen *)ππTYPE CalcStr = RECORDπ stellen : WORD; (* Anzahl der belegten Stellen *)π zahl : ARRAY[1..MAXCALCSTR] OF WORD; (* große Zahl *)π END;ππPROCEDURE InitCalcStr(VAR calcZahl : CalcStr);πPROCEDURE ReverseCalcStr(VAR ergebnis : CalcStr);πPROCEDURE SwapCalcStr(VAR zahl1, zahl2 : CalcStr);πPROCEDURE PrintCalcStr(VAR calcZahl : CalcStr);πPROCEDURE StrToCalcStr(zeichenkette : STRING; VAR ergebnis : CalcStr);πPROCEDURE WordToCalcStr(zahl : WORD; VAR ergebnis : CalcStr);πPROCEDURE AddCalcStr(VAR zahl1, zahl2 : CalcStr; VAR ergebnis : CalcStr);πPROCEDURE SubCalcStr(VAR zahl1, zahl2 : CalcStr; VAR ergebnis : CalcStr);πPROCEDURE Mul2CalcStr(VAR calcZahl : CalcStr);πPROCEDURE Div2CalcStr(VAR calcZahl : CalcStr);πPROCEDURE MulCalcStr(VAR zahl1, zahl2 : CalcStr; VAR ergebnis : CalcStr);πPROCEDURE ExptCalcStr(VAR basis, exponent: CalcStr; VAR ergebnis : CalcStr);πPROCEDURE RandomCalcStr(VAR calcZahl: CalcStr; VAR ergebnis : CalcStr);πPROCEDURE MulModCalcStr(VAR zahl1, zahl2, modul : CalcStr; VAR ergebnis :πCalcStr);πPROCEDURE ExptModCalcStr(VAR basis, exponent, modul : CalcStr; VAR ergebnis :πCalcStr);ππFUNCTION CalcStrLength(VAR calcZahl : CalcStr) : WORD;πFUNCTION CalcStrToStr(VAR calcZahl : CalcStr; VAR ergebnis : STRING) : BOOLEAN;πFUNCTION CalcStrToWord(VAR calcZahl : CalcStr; VAR ergebnis : WORD) : BOOLEAN;πFUNCTION EqualCalcStr(VAR zahl1, zahl2 : CalcStr) : BOOLEAN;πFUNCTION GreaterCalcStr(VAR zahl1, zahl2 : CalcStr) : BOOLEAN;πFUNCTION GreaterEqual(VAR zahl1, zahl2 : CalcStr) : BOOLEAN;πFUNCTION LessCalcStr(VAR zahl1, zahl2 : CalcStr) : BOOLEAN;πFUNCTION LessEqual(VAR zahl1, zahl2 : CalcStr) : BOOLEAN;πFUNCTION EvenCalcStr(VAR calcZahl : CalcStr) : BOOLEAN;πFUNCTION OddCalcStr(VAR calcZahl : CalcStr) : BOOLEAN;πFUNCTION DivCalcStr(VAR zahl1, zahl2 : CalcStr; VAR ergebnis : CalcStr) :πBOOLEAN;πFUNCTION ModCalcStr(VAR zahl1, zahl2 : CalcStr; VAR ergebnis : CalcStr) :πBOOLEAN;ππIMPLEMENTATIONππUSES Crt; (* Ein/Ausgabefunktionen *)ππVAR EMPTYCALCSTR : CalcStr; (* leerer CalcString *)π i : WORD;π (* Zählvariable zur Initialisierung von EMPTYCALCSTR *)ππ(* ======================================================================= *)π(* Bitmanipulationen *)ππ(* ----------------------------------------------------------------------- *)π(* SetBit setzt das BitNr.te Bit in Zahl *)ππFUNCTION SetBit(zahl : WORD; bitNr : BYTE): WORD;πBEGINπ SetBit := zahl OR (1 SHL bitNr)π (* BitNr Stellen nach links shiften und mit oder verknüpfen *)πEND;ππ(* ----------------------------------------------------------------------- *)π(* TestBit prüft, ob das BitNr.te Bit in Zahl gesetzt ist *)ππFUNCTION TestBit(zahl : WORD; bitNr: BYTE): BOOLEAN;πBEGINπ TestBit := (((zahl SHR bitNr) AND 1) = 1)π (* Bit ist dann gesetzt, falls an der BitNr. Stelle bei einer *)π (* Und-Verknüpfung wieder 1 das Ergebnis ist *)πEND;ππ(* ======================================================================= *)π(* Hilfsfunktionen für Strings *)ππ(* ----------------------------------------------------------------------- *)π(* TestString prüft, ob im String eine gültige Zahl enthalten ist *)ππFUNCTION TestString(zeichenkette : STRING) : BOOLEAN;πVAR laenge : BYTE; (* Länge der Zeichenkette *)π i : BYTE; (* Zählvariable *)πBEGINπ laenge := Length(zeichenkette); (* Länge der Zeichenkette ermitteln *)π FOR i := 1 TO laenge DOπ IF (NOT (zeichenkette[i] IN ['0'..'9'])) THEN (* keine Zahl *)π BEGINπ TestString := FALSE; (* String ist ungültig *)π EXIT; (* Funktion verlassen *)π END;π TestString := TRUE;πEND;ππ(* ----------------------------------------------------------------------- *)π(* OddString prüft, ob ein String ungerade ist *)ππFUNCTION OddString(zeichenkette : STRING) : BOOLEAN;πVAR zahl : BYTE; (* Bytedarstellung von Zeichen *)π dummy : INTEGER; (* dient zur Überprüfung von zeichen bei Umwandlung *)π last : CHAR; (* letztes Zeichen in zeichenkette *)π laenge : BYTE; (* Länge der Zeichenkette *)πBEGINπ laenge := Length(zeichenkette); (* Länge muß neu ermittelt werden *)π last := zeichenkette[laenge]; (* letztes Zeichen *)π Val(last, zahl, dummy); (* letztes Zeichen in zahl umwandeln *)π oddString := Odd(zahl); (* prüfen, ob zahl ungerade ist *)πEND;ππ(* ----------------------------------------------------------------------- *)π(* StrDiv2 dividiert einen String durch 2 *)ππFUNCTION StrDiv2(zeichenkette : STRING) : STRING;πVAR hilfe : STRING; (* Hilfsstring für das Ergebnis *)π index : BYTE; (* Index für Position in zeichenkette *)π laenge : BYTE; (* Länge der Zeichenkette *)π zahl : BYTE; (* zu dividierender Faktor *)π zeichen : CHAR; (* Zeichendarstellung von Zahl *)π dummy : INTEGER;π (* dient zur Überprüfung von zeichen bei Umwandlung *)π uebertrag : BOOLEAN; (* ist ein Übertrag aufgetreten *)πBEGINπ hilfe := ''; (* hilfe initialisieren *)π laenge := Length(zeichenkette); (* Länge der zeichenkette *)π IF oddString(zeichenkette) THEN (* falls die Zahl ungerade ist *)π DEC(zeichenkette[laenge]); (* Zahl um 1 dekrementieren *)π uebertrag := FALSE; (* kein Übertrag *)π IF zeichenkette[1] = '1' THEN (* falls an 1.Stelle ein 1er *)π BEGINπ index := 2; (* an 2.Stelle weitermachen *)π zahl := 10; (* Übertrag an 1.Stelle => zahl = 10 *)π ENDπ ELSEπ BEGINπ index := 1; (* beginne bei 1.Stelle *)π zahl := 0; (* => zahl = 0 *)π END;π REPEATπ zahl := zahl + Ord(zeichenkette[index]) - 48; (* Zahl ermitteln *)π IF (zahl AND 1) = 1 THEN uebertrag := TRUE;π (* ungerade zahl => Übertrag *)π zahl := zahl SHR 1; (* zahl durch 2 dividieren *)π zeichen := Chr(zahl + 48); (* Zahl wieder in ASCII-Zeichen umwandeln *)π hilfe := hilfe + zeichen; (* und an hilfe anhängen *)π INC(index); (* Index um 1 erhöhen *)π IF uebertrag THEN (* Übertrag *)π zahl := 10 (* Übertrag in zahl sichern *)π ELSEπ zahl := 0; (* sonst zahl = 0 *)π uebertrag := FALSE; (* Annahme: kein Übertrag *)π UNTIL index > laenge; (* keine Zeichen mehr zum dividieren *)π StrDiv2 := hilfe; (* Ergebnis steht in Hilfe *)πEND;ππ(* ----------------------------------------------------------------------- *)π(* StrMul2 multipliziert einen String mit 2 *)ππFUNCTION StrMul2(zeichenkette : STRING) : STRING;πVAR laenge : BYTE; (* Laenge der zeichenkette *)π i : BYTE; (* Zählvariable *)π hilfe : STRING; (* Hilfsstring für Ergebnis *)π dummyStr : STRING; (* dient zur Umwandlung Zahl -> Zeichen *)π uebertrag : BOOLEAN; (* Übertrag ja/nein *)π zeichen : CHAR; (* aktuelles Zeichen *)π zahl : BYTE; (* Byte-Darstellung von zeichen *)π dummy : INTEGER; (* dient zur Prüfung von zeichen bei Umwandlung *)πBEGINπ laenge := Length(zeichenkette); (* Länge ermitteln *)π uebertrag := FALSE; (* Annahme: kein Übertrag *)π hilfe := ''; (* Hilfsstring initialisieren *)π FOR i := laenge DOWNTO 1 DO (* zeichenkette rückwärts durchlaufen *)π BEGINπ zeichen := zeichenkette[i]; (* aktuelles Zeichen ermitteln *)π zahl := Ord(zeichen) - 48; (* in eine Zahl umwandeln *)π zahl := zahl SHL 1; (* Zahl mit 2 multiplizieren *)π IF uebertrag THEN INC(zahl); (* bei Übertrag 1 addieren *)π IF (zahl >= 10) THEN (* falls Zahl >= 10 *)π BEGINπ uebertrag := TRUE; (* Übertrag aufgetreten *)π zahl := zahl - 10; (* Übertrag wegschneiden *)π ENDπ ELSEπ uebertrag := FALSE; (* sonst kein Übertrag *)π zeichen := Chr(zahl + 48); (* zahl in Zeichen umwandeln *)π hilfe := zeichen + hilfe; (* und an Hilfe anhängen *)π END;π IF uebertrag THEN hilfe := '1' + hilfe;π (* restlichen Übertrag noch berücksichtigen *)π StrMul2 := hilfe; (* Ergebnis zuweisen *)πEND;ππ(* ======================================================================= *)π(* Operationen auf den Datentyp CalcString *)ππ(* ----------------------------------------------------------------------- *)π(* InitCalcStr initialisiert einen CalcString: *)ππPROCEDURE InitCalcStr(VAR calcZahl : CalcStr);πBEGINπ calcZahl := EMPTYCALCSTR; (* leeren CalcStr zuweisen *)πEND;ππ(* ----------------------------------------------------------------------- *)π(* CalcStrLength liefert die Länge des CalcStrings zurück *)ππFUNCTION CalcStrLength(VAR calcZahl : CalcStr) : WORD;πBEGINπ CalcStrLength := calcZahl.stellen; (* Länge ist in stellen gespeichert *)πEND;ππ(* ----------------------------------------------------------------------- *)π(* ReverseCalcStr dreht einen CalcString um *)ππPROCEDURE ReverseCalcStr(VAR ergebnis : CalcStr);πVAR laenge : WORD; (* Anzahl Stellen im CalcString *)π i : WORD; (* Zählvariable *)π anzahl : WORD; (* benötigte Schrittzahl *)π hilfe : WORD; (* Zwischenspeicher *)πBEGINπ laenge := CalcStrLength(ergebnis); (* Länge des CalcStrings ermitteln *)π anzahl := laenge DIV 2; (* man benötigt nur laenge/2 Schritte *)π WITH ergebnis DO (* Record abarbeiten *)π BEGINπ FOR i := 1 TO anzahl DOπ BEGINπ hilfe := zahl[i]; (* i. Zahl merken *)π zahl[i] := zahl[laenge - (i - 1)];π (* i. Zahl wird zur entsprechenden Zahl von hinten *)π zahl[laenge - (i - 1)] := hilfe; (* hintere Zahl wird i.te Zahl *)π END;π END;πEND;ππ(* ----------------------------------------------------------------------- *)π(* SwapCalcStr vertauscht zwei CalcStrings *)ππPROCEDURE SwapCalcStr(VAR zahl1, zahl2 : CalcStr);πVAR hilfe : CalcStr; (* HilfsString für Vertauschung *)πBEGINπ hilfe := zahl1; (* Hilfe auf Zahl1 setzen *)π zahl1 := zahl2; (* Zahl1 auf Zahl2 setzen *)π zahl2 := hilfe; (* Zahl2 auf Hilfe setzen *)πEND;ππ(* ----------------------------------------------------------------------- *)π(* PrintCalcStr gibt einen CalcString als Vektor auf dem Bildschirm aus *)ππPROCEDURE PrintCalcStr(VAR calcZahl : CalcStr);πVAR i : WORD; (* Zählvariable *)πBEGINπ ReverseCalcStr(calcZahl); (* calcZahl muß umgedreht werden *)π WITH calcZahl DO (* Recordtyp als Grundlage *)π BEGINπ IF stellen > 0 THEN (* Zahl darf nicht 0 sein *)π BEGINπ Write('('); (* positives Vorzeichen *)π FOR i := 1 TO (stellen - 1) DO (* alle Stellen abarbeiten *)π BEGINπ Write(zahl[i]); (* Zahl ausgeben *)π Write(','); (* durch Beistrich trennen *)π END;π Write(zahl[stellen]); (* letzte Zahl ausgeben *)π WriteLn(')'); (* Klammer des Vektors schließen *)π ENDπ ELSEπ WriteLn('(0)'); (* sonst 0 ausgeben *)π END;π ReverseCalcStr(calcZahl); (* calcZahl muß wieder umgedreht werden *)πEND;ππ(* ----------------------------------------------------------------------- *)π(* StrToCalcStr wandelt einen String in einen CalcString um *)ππPROCEDURE StrToCalcStr(zeichenkette : STRING; VAR ergebnis : CalcStr);πVAR index : WORD; (* Index im ErgebnisCalcString *)π bitnr : BYTE; (* Nummer des zu setzenden Bit's *)π laenge : BYTE; (* Länge der Zeichenkette *)πBEGINπ ergebnis := EMPTYCALCSTR; (* ErgebnisString initialisieren *)π index := 1; (* erstes Element im CalcString *)π ergebnis.stellen := 1; (* Länge des CalcStrings wird auf 1 gesetzt *)π bitnr := 0; (* zu Beginn wird Bit 0 gesetzt/nicht gesetzt *)π laenge := Length(zeichenkette); (* Länge der Zeichenkette ermitteln *)π IF TestString(zeichenkette) THEN (* ist zeichenkette eine gültige Zahl *)π WITH ergebnis DO (* Record als Grundlage *)π BEGINπ REPEATπ IF oddString(zeichenkette) THEN (* ist zeichenkette ungerade ? *)π zahl[index] := SetBit(zahl[index], bitnr); (* Bit setzen *)π zeichenkette := StrDiv2(zeichenkette); (* Zeichenkette / 2 *)π IF zeichenkette <> '0' THEN (* falls noch nicht fertig *)π BEGINπ INC(bitnr); (* BitNr um 1 erhöhen *)π IF bitnr >= 16 THEN (* falls 1 Word voll ist *)π BEGINπ bitnr := 0; (* BitNr wird wieder 0 *)π INC(index); (* ein Element im CalcString weiter *)π INC(stellen); (* Länge des CalcStrings wird um 1 erhöht *)π END;π END;π UNTIL zeichenkette = '0'; (* bis zeichenkette auf 0 reduziert *)π END;πEND;ππ(* ----------------------------------------------------------------------- *)π(* CalcStrToStr wandelt eine CalcString um, falls er sich als String *)π(* darstellen läßt *)ππFUNCTION CalcStrToStr(VAR calcZahl : CalcStr; VAR ergebnis : STRING) : BOOLEAN;πVAR i : WORD; (* Zählvariable *)π BitNr : BYTE; (* Nummer des aktuellen Bits *)π anzahl : WORD; (* Anzahl Stellen im CalcString *)π laenge : BYTE; (* Länge des Ergebnisstrings *)πBEGINπ IF calcZahl.Stellen > 50 THEN (* Stringlänge würde überschritten *)π CalcStrToStr := FALSE (* Stringüberlauf *)π ELSEπ BEGIN (* Zahl paßt in einen String *)π ergebnis := '0'; (* Ergebnisstring ist zu Beginn 0 *)π anzahl := CalcStrLength(calcZahl); (* Länge des CalcStrings *)π FOR i := anzahl DOWNTO 1 DOπ (* alle Element des CalcStrings durchlaufen *)π FOR BitNr := 15 DOWNTO 0 DO (* alle Bits prüfen *)π BEGINπ ergebnis := StrMul2(ergebnis); (* ErgebnisString mit 2 mult. *)π IF TestBit(calcZahl.zahl[i], BitNr) THENπ (* Ist das Bit gesetzt ? *)π BEGINπ laenge := Length(ergebnis); (* Länge ermitteln *)π INC(ergebnis[laenge]); (* letztes Zeichen um 1 erhöhen *)π END;π END;π CalcStrToStr := TRUE; (* Umwandlung geglückt *)π END;πEND;ππ(* ----------------------------------------------------------------------- *)π(* WordToCalcStr wandelt eine Wordzahl in einen CalcString um *)ππPROCEDURE WordToCalcStr(zahl : WORD; VAR ergebnis : CalcStr);πBEGINπ ergebnis := EMPTYCALCSTR; (* Ergebnis initialisieren *)π ergebnis.stellen := 1; (* 1 Stelle wird belegt *)π ergebnis.zahl[1] := zahl; (* Zahl in CalcZahl sichern *)πEND;ππ(* ----------------------------------------------------------------------- *)π(* CalcStrToWord wandelt einen CalcString in eine Wordzahl um *)ππFUNCTION CalcStrToWord(VAR calcZahl : CalcStr; VAR ergebnis : WORD) : BOOLEAN;πBEGINπ IF (calcZahl.Stellen > 1) THENπ (* Zahl mit mehr als 1 Stelle können nicht umgewandelt werden *)π CalcStrToWord := FALSE (* keine Umwandlung *)π ELSEπ BEGINπ ergebnis := calcZahl.zahl[1]; (* Ergebnis zurückgeben *)π CalcStrToWord := TRUE; (* Umwandlung geglückt *)π END;πEND;ππ(* ----------------------------------------------------------------------- *)π(* EqualCalcStr prüft, ob ein CalcStr1 = CalcStr2 *)ππFUNCTION EqualCalcStr(VAR zahl1, zahl2 : CalcStr) : BOOLEAN;πVAR i : WORD; (* Zählvariable *)πBEGINπ IF (zahl1.stellen <> zahl2.stellen) THENπ EqualCalcStr := FALSE (* unterschiedliche Anzahl Stellen *)π ELSE (* Stellenzahl gleich *)π BEGINπ FOR i := 1 TO zahl1.stellen DO (* alle Stellen abarbeiten *)π IF zahl1.zahl[i] <> zahl2.zahl[i] THEN (* Zahlen verschieden *)π BEGINπ EqualCalcStr := FALSE; (* Zahlen sind verschieden *)π EXIT; (* Schleife verlassen *)π END;π EqualCalcStr := TRUE; (* Zahlen sind gleich *)π END;πEND;ππ(* ----------------------------------------------------------------------- *)π(* GreaterCalcStr prüft, ob ein CalcStr1 > CalcStr2 *)ππFUNCTION GreaterCalcStr(VAR zahl1, zahl2 : CalcStr) : BOOLEAN;πVAR i : WORD; (* Zählvariable *)π hilfe : BOOLEAN; (* Hilfsvariable *)πBEGINπ IF (zahl1.stellen > zahl2.stellen) THEN (* Zahl1 besitzt mehr Stellen *)π GreaterCalcStr := TRUE (* => Zahl1 > Zahl2 *)π ELSEπ IF (zahl1.stellen < zahl2.stellen) THENπ (* Zahl1 besitzt weniger Stellen *)π GreaterCalcStr := FALSE (* => Zahl1 nicht > Zahl2 *)π ELSE (* Stellenzahl gleich *)π BEGINπ FOR i := zahl1.stellen DOWNTO 1 DO (* alle Stellen abarbeiten *)π IF zahl1.zahl[i] > zahl2.zahl[i] THENπ (* i.Stelle von Zahl1 > i.te Stelle von Zahl2 *)π BEGINπ GreaterCalcStr := TRUE; (* Zahl1 > Zahl2 *)π EXIT; (* Schleife verlassen *)π ENDπ ELSEπ IF zahl1.zahl[i] < zahl2.zahl[i] THENπ (* i.Stelle von Zahl1 < i.te Stelle von Zahl2 *)π BEGINπ GreaterCalcStr := FALSE; (* Zahl1 nicht > Zahl2 *)π EXIT; (* Schleife verlassen *)π END;π GreaterCalcStr := FALSE; (* alle Stellen sind gleich *)π END;πEND;ππ(* ----------------------------------------------------------------------- *)π(* GreaterEqual prüft, ob Zahl1 >= Zahl2 *)ππFUNCTION GreaterEqual(VAR zahl1, zahl2 : CalcStr) : BOOLEAN;πBEGINπ GreaterEqual := NOT LessCalcStr(zahl1, zahl2);π (* Zahl1 >= Zahl2, wenn Zahl1 nicht kleiner als Zahl2 ist *)πEND;ππ(* ----------------------------------------------------------------------- *)π(* LessCalcStr prüft, on Zahl1 < Zahl2 *)ππFUNCTION LessCalcStr(VAR zahl1, zahl2 : CalcStr) : BOOLEAN;πVAR i : WORD; (* Zählvariable *)π hilfe : BOOLEAN; (* Hilfsvariable *)πBEGINπ IF (zahl1.stellen < zahl2.stellen) THEN (* Zahl1 besitzt weniger Stellen *)π LessCalcStr := TRUE (* => Zahl1 < Zahl2 *)π ELSEπ IF (zahl1.stellen > zahl2.stellen) THEN (* Zahl1 besitzt mehr Stellen *)π LessCalcStr := FALSE (* => Zahl1 nicht < Zahl2 *)π ELSE (* Stellenzahl gleich *)π BEGINπ FOR i := zahl1.stellen DOWNTO 1 DO (* alle Stellen abarbeiten *)π IF zahl1.zahl[i] < zahl2.zahl[i] THENπ (* i.Stelle von Zahl1 < i.te Stelle von Zahl2 *)π BEGINπ LessCalcStr := TRUE; (* Zahl1 < Zahl2 *)π EXIT; (* Schleife verlassen *)π ENDπ ELSEπ IF zahl1.zahl[i] > zahl2.zahl[i] THENπ (* i.Stelle von Zahl1 > i.te Stelle von Zahl2 *)π BEGINπ LessCalcStr := FALSE; (* Zahl1 nicht < Zahl2 *)π EXIT; (* Schleife verlassen *)π END;π LessCalcStr := FALSE; (* alle Stellen sind gleich *)π END;πEND;ππ(* ----------------------------------------------------------------------- *)π(* LessEqual prüft, ob Zahl1 <= Zahl2 *)ππFUNCTION LessEqual(VAR zahl1, zahl2 : CalcStr) : BOOLEAN;πBEGINπ LessEqual := NOT GreaterCalcStr(zahl1, zahl2);π (* Zahl1 <= Zahl2, wenn Zahl1 nicht größer als Zahl2 ist *)πEND;ππ(* ----------------------------------------------------------------------- *)π(* EvenCalcStr prüft, ob ein CalcString gerade ist *)ππFUNCTION EvenCalcStr(VAR calcZahl : CalcStr) : BOOLEAN;πBEGINπ EvenCalcStr := NOT Odd(calcZahl.zahl[1]);π (* CalcZahl ist gerade, falls die letzte Stelle nicht ungerade ist *)πEND;ππ(* ----------------------------------------------------------------------- *)π(* OddCalcStr prüft, ob ein CalcString ungerade ist *)ππFUNCTION OddCalcStr(VAR calcZahl : CalcStr) : BOOLEAN;πBEGINπ OddCalcStr := Odd(calcZahl.zahl[1]);π (* CalcZahl ist ungerade, falls die letzte Stelle ungerade ist *)πEND;ππ(* ----------------------------------------------------------------------- *)π(* AddCalcStr addiert zwei CalcStrings *)ππPROCEDURE AddCalcStr(VAR zahl1, zahl2 : CalcStr; VAR ergebnis : CalcStr);πVAR anzahl : WORD; (* Anzahl Stellen für Addition *)π i : WORD; (* Zählvariable *)π summe : LongInt; (* Hilfsvariable zur Prüfung eines Übertrags *)π ueberlauf : BYTE; (* Überlauf = 1, kein Überlauf = 0 *)π addition : BOOLEAN; (* können Zahlen addiert werden oder nicht *)πBEGINπ {$Q-} (* Überlaufprüfung ausschalten *)π ergebnis := EMPTYCALCSTR; (* Ergebnis initialisieren *)π anzahl := zahl1.stellen; (* Annahme: Zahl 1 ist größer *)π IF zahl2.stellen > anzahl THEN (* Falls doch 2. Zahl größer ist *)π anzahl := zahl2.stellen; (* so viele Stellen müssen addiert werden *)π ueberlauf := 0; (* zu Beginn kein Überlauf *)π FOR i := 1 TO anzahl DO (* anzahl Stellen abarbeiten *)π BEGINπ ergebnis.zahl[i] := zahl1.zahl[i] + zahl2.zahl[i] + ueberlauf;π (* ergebnis ist die Summe der beiden Zahlen (kann einfach *)π (* addiert werden, weil Überlaufprüfung ausgeschaltet ist *)π summe := LongInt(zahl1.zahl[i]) + LongInt(zahl2.zahl[i]) + ueberlauf;π (* Summe ohne Überlauf *)π IF (summe > ergebnis.zahl[i]) THEN (* ist ein Überlauf aufgetreten *)π ueberlauf := 1 (* ja -> Überlauf auf 1 setzen *)π ELSEπ ueberlauf := 0; (* nein -> Überlauf ist 0 *)π END;π IF (ueberlauf = 1) THEN (* letzter Überlauf muß geprüft werden *)π BEGINπ ergebnis.stellen := anzahl + 1; (* letzter Überlauf belegt 1 Feld *)π ergebnis.zahl[anzahl + 1] := 1; (* Zahl 1 steht im letzten Feld *)π ENDπ ELSEπ ergebnis.stellen := anzahl;π (* gleich viele Stellen wie die längere Zahl *)π {$Q+} (* Überlaufprüfung wieder einschalten *)πEND;ππ(* ----------------------------------------------------------------------- *)π(* SubCalcStr subtrahiert zahl2 von zahl1 *)ππPROCEDURE SubCalcStr(VAR zahl1, zahl2 : CalcStr; VAR ergebnis : CalcStr);πVAR swapped : BOOLEAN; (* wurden Zahl1 und Zahl2 vertauscht ? *)π i : WORD; (* Zählvariable *)π uebertrag : BYTE; (* Übertrag: 1, kein Übertrag: 0 *)πBEGINπ ergebnis := EMPTYCALCSTR; (* Ergebnis initialisieren *)π swapped := FALSE; (* Zahlen wurden nicht vertauscht *)π uebertrag := 0; (* kein Übertrag *)π IF GreaterCalcStr(zahl2, zahl1) THEN EXIT; (* Zahl2 > Zahl1 *)π FOR i := 1 TO zahl1.stellen DO (* alle Stellen abarbeiten *)π BEGINπ IF (zahl1.zahl[i] >= (zahl2.zahl[i] + uebertrag)) THENπ (* Zahl1[i] >= Zahl2[i] mit Berücksichtigung des Übertrags *)π BEGINπ ergebnis.zahl[i] := zahl1.zahl[i] - (zahl2.zahl[i] + uebertrag);π (* Differenz der Zahlen ermitteln *)π uebertrag := 0; (* kein Übertrag *)π ENDπ ELSEπ BEGINπ ergebnis.zahl[i] := LongInt(zahl1.zahl[i] + 65536) - (zahl2.zahl[i] +πuebertrag);π uebertrag := 1;π END;π END;π ergebnis.stellen := zahl1.stellen;π (* Annahme: gleich viel Stellen wie Zahl1 *)π WHILE (ergebnis.zahl[ergebnis.stellen] = 0) AND (ergebnis.stellen > 0) DOπ DEC(ergebnis.stellen); (* richtige Stellenzahl ermitteln *)πEND;ππ(* ----------------------------------------------------------------------- *)π(* Mul2CalcStr multipliziert einen CalcString mit 2 *)ππPROCEDURE Mul2CalcStr(VAR calcZahl : CalcStr);πVAR i : WORD; (* Zählvariable *)πBEGINπ WITH calcZahl DO (* Record als Grundlage *)π IF ((stellen = 1) AND (zahl[1] = 0)) OR (stellen = 0) THENπ ELSE (* CalcZahl ist 0 => Ergebnis ist 0 *)π BEGIN (* Sonst ist Ergebnis <> 0 *)π IF (zahl[stellen] AND 32768) > 0 THENπ BEGIN (* Ist 16.Bit der letzten Stelle gesetzt ? *)π INC(stellen); (* Stellenzahl um 1 erhöhen *)π zahl[stellen] := 0; (* und mit 0 initialisieren *)π END;π FOR i := (stellen - 1) DOWNTO 1 DO (* Zahl abarbeiten *)π BEGINπ zahl[i + 1] := zahl[i + 1] SHL 1; (* Zahl[i + 1] * 2 *)π IF (zahl[i] AND 32768) > 0 THEN INC(zahl[i + 1]);π END; (* Bei Überlauf bei Zahl[i] => Zahl[i + 1] erhöhen *)π zahl[1] := zahl[1] SHL 1; (* 1. Zahl mit 2 multiplizieren *)π END;πEND;ππ(* ----------------------------------------------------------------------- *)π(* Div2CalcStr dividiert einen CalcString durch 2 *)ππPROCEDURE Div2CalcStr(VAR calcZahl : CalcStr);πVAR i : WORD; (* Zählvariable *)πBEGINπ WITH calcZahl DOπ IF ((stellen = 1) AND (zahl[1] = 0)) OR (stellen = 0) THENπ ELSE (* calcZahl = 0 => calcZahl * 2 = 0 *)π BEGINπ FOR i := 1 TO (stellen - 1) DO (* Zahl abarbeiten *)π BEGINπ zahl[i] := zahl[i] SHR 1; (* Zahl[i] DIV 2 *)π IF (zahl[i + 1] AND 1) > 0 THENπ (* Falls bei Zahl[i + 1] ein Unterlauf auftritt *)π zahl[i] := zahl[i] OR 32768; (* Bit 16 bei Zahl[i] setzen *)π END;π zahl[stellen] := zahl[stellen] SHR 1; (* letzte Stelle DIV 2 *)π IF (zahl[stellen] = 0) THEN DEC(stellen);π (* Falls letzte Stelle 0 ist => Stellen um 1 erniedrigen *)π END;πEND;ππ(* ----------------------------------------------------------------------- *)π(* MulCalcStr multiplizier2 zahl1 mit zahl2 *)ππPROCEDURE MulCalcStr(VAR zahl1, zahl2 : CalcStr; VAR ergebnis : CalcStr);πVAR hilfe : CalcStr; (* HilfsCalcString *)π hilfe1 : CalcStr; (* HilfsCalcString *)π hilfe2 : CalcStr; (* HilfsCalcString *)π i, j : WORD; (* Zählvariablen *)π wert : WORD; (* Wert von Zahl an der i.ten Stelle *)πBEGINπ IF LessCalcStr(zahl1, zahl2) THEN (* Falls zahl1 < zahl2 *)π BEGINπ hilfe1 := zahl1; (* Hilfe1 wird Zahl1 zugewiesen *)π hilfe2 := zahl2; (* Hilfe2 wird Zahl2 zugewiesen *)π ENDπ ELSEπ BEGINπ hilfe2 := zahl1; (* Hilfe2 wird Zahl1 zugewiesen *)π hilfe1 := zahl2; (* Hilfe1 wird Zahl2 zugewiesen *)π END;π ergebnis := EMPTYCALCSTR; (* Ergebnis initialisieren *)π IF ((hilfe1.stellen = 1) AND (hilfe1.zahl[1] = 0)) OR (hilfe1.stellen = 0)πTHENπ ELSE (* Ergebnis=0, weil X * 0 = 0 *)π BEGINπ i := 1; (* i mit 1 initialisieren *)π WHILE (i <= (hilfe1.stellen - 1)) DO (* Hilfe 1 abarbeiten *)π BEGINπ wert := hilfe1.zahl[i]; (* Wert = i.Zahl *)π j := 1; (* j mit 1 initialisieren *)π WHILE (j <= 16) DO (* alle Bits abarbeiten *)π BEGINπ IF (wert AND 1) > 0 THEN (* Falls 1.Bit gesetzt *)π BEGINπ AddCalcStr(ergebnis, hilfe2, hilfe);π (* Ergebnis und Hilfe2 addieren *)π ergebnis := hilfe; (* Ergebnis aus Addition *)π END;π wert := wert SHR 1; (* Wert DIV 2 *)π Mul2CalcStr(hilfe2); (* Hilfe2 * 2 *)π INC(j); (* j um 1 erhöhen *)π END;π INC(i); (* i um 1 erhöhen *)π END;π wert := hilfe1.zahl[hilfe1.stellen]; (* letzte Stelle behandeln *)π WHILE wert > 0 DO (* Solange noch 1 Bit gesetzt ist *)π BEGINπ IF (wert AND 1) > 0 THEN (* Falls Bit 1 gesetzt ist *)π BEGINπ AddCalcStr(ergebnis, hilfe2, hilfe);π (* Ergebnis und Hilfe2 addieren *)π ergebnis := hilfe; (* Ergebnis aus Addition *)π END;π wert := wert SHR 1; (* Wert DIV 2 *)π Mul2CalcStr(hilfe2); (* Hilfe2 * 2 *)π END;π END;πEND;ππ(* ----------------------------------------------------------------------- *)π(* DivCalcStr dividiert einen CalcString durch einen anderen *)ππFUNCTION DivCalcStr(VAR zahl1, zahl2 : CalcStr; VAR ergebnis : CalcStr) :πBOOLEAN;πVAR hilfe : CalcStr; (* HilfsCalcString *)ππ hilfe1 : CalcStr; (* HilfsCalcString *)π hilfe2 : CalcStr; (* HilfsCalcString *)π EINS : CalcStr; (* konstanter HilfsString für 1 *)πBEGINπ IF ((zahl2.stellen = 1) AND (zahl2.zahl[1] = 0)) OR (zahl2.stellen = 0) THENπ DivCalcStr := FALSE (* Division durch 0 nicht möglich *)π ELSEπ BEGINπ EINS := EMPTYCALCSTR; (* Eins initialisieren *)π EINS.stellen := 1; (* Eins besitzt 1 Stelle *)π EINS.zahl[1] := 1; (* diese wird mit 1 belegt *)π ergebnis := EMPTYCALCSTR; (* Ergebnis initialisieren *)π hilfe1 := zahl1; (* Hilfe1 wird Zahl1 zugewiesen *)π hilfe2 := zahl2; (* Hilfe2 wird Zahl2 zugewiesen *)π WHILE NOT (GreaterCalcStr(hilfe2, hilfe1)) DOπ Mul2CalcStr(hilfe2);π (* schiebe hilfe2 solange nach links, bis dividiert werden kann *)π WHILE NOT (EqualCalcStr(hilfe2, zahl2)) DO (* Abbruchbedingung *)π BEGINπ Mul2CalcStr(ergebnis); (* Ergebnis mit 2 multiplizieren *)π Div2CalcStr(hilfe2); (* Hilfe2 durch 2 dividieren *)π IF NOT (GreaterCalcStr(hilfe2, hilfe1)) THENπ (* falls hilfe2 nicht > hilfe1 *)π BEGINπ SubCalcStr(hilfe1, hilfe2, hilfe); (* Hilfe1 - Hilfe2 *)π hilfe1 := hilfe; (* Hilfe1 wird Hilfe zugewiesen *)π AddCalcStr(ergebnis, EINS, hilfe);(* zum Ergebnis 1 addieren *)π ergebnis := hilfe; (* Ergebnis wird hilfe zugewiesen *)π END;π END;π DivCalcStr := TRUE; (* Division erfolgreich *)π END;πEND;ππ(* ----------------------------------------------------------------------- *)π(* ModCalcStr berechnet den Rest bei Division von Zahl1 durch Zahl2 *)ππFUNCTION ModCalcStr(VAR zahl1, zahl2 : CalcStr; VAR ergebnis : CalcStr) :πBOOLEAN;πVAR hilfe : CalcStr; (* HilfsCalcString *)π hilfe1 : CalcStr; (* HilfsCalcString *)π hilfe2 : CalcStr; (* HilfsCalcString *)π EINS : CalcStr; (* konstanter HilfsString für 1 *)πBEGINπ IF ((zahl2.stellen = 1) AND (zahl2.zahl[1] = 0)) OR (zahl2.stellen = 0) THENπ ModCalcStr := FALSE (* Division durch 0 nicht möglich *)π ELSEπ BEGINπ EINS := EMPTYCALCSTR; (* Eins initialisieren *)π EINS.stellen := 1; (* Eins besitzt 1 Stelle *)π EINS.zahl[1] := 1; (* diese wird mit 1 belegt *)π ergebnis := EMPTYCALCSTR; (* Ergebnis initialisieren *)π IF GreaterCalcStr(zahl2, zahl1) THEN (* falls Zahl2 > Zahl1 *)π ergebnis := zahl1 (* Ergebnis ist Zahl1 *)π ELSEπ BEGINπ hilfe1 := zahl1; (* Hilfe1 wird Zahl1 zugewiesen *)π hilfe2 := zahl2; (* Hilfe2 wird Zahl2 zugewiesen *)π WHILE NOT (GreaterCalcStr(hilfe2, hilfe1)) DOπ Mul2CalcStr(hilfe2);π (* schiebe hilfe2 solange nach links, bis dividiert werden kann *)π WHILE NOT (EqualCalcStr(hilfe2, zahl2)) DO (* Abbruchbedingung *)π BEGINπ Mul2CalcStr(ergebnis); (* Ergebnis mit 2 multiplizieren *)π Div2CalcStr(hilfe2); (* Hilfe2 durch 2 dividieren *)π IF NOT (GreaterCalcStr(hilfe2, hilfe1)) THENπ (* falls hilfe2 nicht > hilfe1 *)π BEGINπ SubCalcStr(hilfe1, hilfe2, hilfe); (* Hilfe1 - Hilfe2 *)π hilfe1 := hilfe; (* Hilfe1 wird Hilfe zugewiesen *)π AddCalcStr(ergebnis, EINS, hilfe);π (* zum Ergebnis 1 addieren *)π ergebnis := hilfe; (* Ergebnis wird hilfe zugewiesen *)π END;π END;π ModCalcStr := TRUE; (* Division erfolgreich *)π END;π END;πEND;ππ(* ----------------------------------------------------------------------- *)π(* ExptCalcStr berechnet Basis^Exponent *)ππPROCEDURE ExptCalcStr(VAR basis, exponent: CalcStr; VAR ergebnis : CalcStr);πVAR hilfe : CalcStr; (* HilfsCalcString *)π hilfe1 : CalcStr; (* HilfsCalcString *)π i, j : WORD; (* Zählvariablen *)π wert : WORD; (* Wert des Exponenten an der i.ten Stelle *)πBEGINπ ergebnis := EMPTYCALCSTR; (* Ergebnis initialisieren *)π ergebnis.stellen := 1; (* Ergebnis hat min. 1 Stelle *)π ergebnis.zahl[1] := 1; (* Ergebnis >= 1 *)π IF ((exponent.stellen = 1) AND (exponent.zahl[1] = 0)) OR (exponent.stellen =π0) THENπ ELSE (* Exponent = 0 => Ergebnis = 1 *)π BEGINπ hilfe1 := basis; (* Hilfe1 wird Basis zugewiesen *)π i := 1; (* i wird mit 1 initialisiert *)π WHILE (i <= (exponent.stellen - 1)) DO (* Exponenten abarbeiten *)π BEGINπ wert := exponent.zahl[i]; (* i.te Stelle des Exponenten *)π INC(i); (* i um 1 erhöhen *)π j := 1; (* j wird mit 1 initialisiert *)π WHILE (j <= 16) DO (* alle Bits abarbeiten *)π BEGINπ IF (wert AND 1) = 1 THEN (* falls 1. Bit gesetzt ist *)π MulCalcStr(ergebnis, hilfe1, ergebnis);π (* Ergebnis mit Hilfe1 multiplizieren *)π MulCalcStr(hilfe1, hilfe1, hilfe1); (* Hilfe1 quadrieren *)π wert := wert SHR 1; (* Wert DIV 2 *)π INC(j); (* 1 Bit weitergehen *)π END;π END;π wert := exponent.zahl[exponent.stellen]; (* letzte Stelle behandeln *)π WHILE (wert <> 0) DO (* solange noch 1 Bit gesetzt *)π BEGINπ IF (wert AND 1) = 1 THEN (* falls 1. Bit gesetzt ist *)π MulCalcStr(ergebnis, hilfe1, ergebnis);π (* Ergebnis mit Hilfe1 multiplizieren *)π MulCalcStr(hilfe1, hilfe1, hilfe1); (* Hilfe1 quadrieren *)π wert := wert SHR 1; (* Wert DIV 2 *)π END;π END;πEND;ππ(* ----------------------------------------------------------------------- *)π(* RandomCalcStr liefert eine Zufallszahl < calcZahl *)ππPROCEDURE RandomCalcStr(VAR calcZahl: CalcStr; VAR ergebnis : CalcStr);πVAR i : WORD; (* Zählvariable *)πBEGINπ ergebnis := EMPTYCALCSTR; (* Ergebnis initialisieren *)π ergebnis.stellen := calcZahl.stellen; (* Annahme: Stellenzahl ist gleich *)π FOR i := 1 TO (calcZahl.stellen - 1) DOπ ergebnis.zahl[i] := Random(65535); (* zufällige Zahl < 65535 *)π ergebnis.zahl[ergebnis.stellen] := Random(calcZahl.zahl[calcZahl.stellen]);π (* letzte Zahl muß kleiner Ausgangszahl sein *)π WHILE (ergebnis.zahl[ergebnis.stellen] = 0) AND (ergebnis.stellen > 1) DOπ DEC(ergebnis.stellen); (* führende Nullen abschneiden *)π IF ((ergebnis.stellen = 1) AND (ergebnis.zahl[1] = 0)) OR (ergebnis.stellen =π0) THENπ BEGIN (* Ergebnis darf nicht 0 sein *)π ergebnis.stellen := 1; (* min. 1 Stelle *)π ergebnis.zahl[1] := 1; (* diese mit 1 besetzen *)π END;πEND;ππ(* ----------------------------------------------------------------------- *)π(* MulModCalcStr multipliziert ein Zahl modulo modul *)ππPROCEDURE MulModCalcStr(VAR zahl1, zahl2, modul : CalcStr; VAR ergebnis :πCalcStr);πVAR i, j : WORD; (* Zählvariablen *)π wert : WORD; (* Wert von Zahl an i.ter Stelle *)π hilfe : CalcStr; (* HilfsCalcString *)π hilfe1 : CalcStr; (* HilfsCalcString *)π hilfe2 : CalcStr; (* HilfsCalcString *)πBEGINπ IF LessCalcStr(zahl1, zahl2) THEN (* Falls Zahl1 < Zahl2 *)π BEGINπ ModCalcStr(zahl1, modul, hilfe1); (* Divisionsrest Zahl1/Modul *)π ModCalcStr(zahl2, modul, hilfe2); (* Divisionsrest Zahl2/Modul *)π ENDπ ELSEπ BEGINπ ModCalcStr(zahl1, modul, hilfe2); (* Divisionsrest Zahl1/Modul *)π ModCalcStr(zahl2, modul, hilfe1); (* Divisionsrest Zahl2/Modul *)π END;π ergebnis := EMPTYCALCSTR; (* ErgebnisCalcString initialisieren *)π IF ((hilfe1.stellen = 1) AND (hilfe1.zahl[1] = 0)) OR (hilfe1.stellen = 0)πTHENπ (* Hilfe1 muß ungleich 0 sein *)π ELSEπ BEGINπ i := 1; (* i mit 1 initialisieren *)π WHILE (i <= (hilfe1.stellen - 1)) DOπ (* alle Stellen von Hilfe1 abarbeiten *)π BEGINπ wert := hilfe1.zahl[i]; (* aktuellen Wert ermitteln *)π j := 1; (* j mit 1 initialisieren *)π WHILE (j <= 16) DO (* alle Bits abarbeiten *)π BEGINπ IF (wert AND 1) > 0 THEN (* Falls Bit 1 gesetzt ist *)π BEGINπ AddCalcStr(ergebnis, hilfe2, hilfe);π (* Hilfe2 zum Ergebnis addieren *)π ergebnis := hilfe; (* und dem Ergebnis zuweisen *)π END;π wert := wert SHR 1; (* Wert durch 2 dividieren *)π Mul2CalcStr(hilfe2); (* Hilfe2 mit 2 multiplizieren *)π INC(j); (* j um 1 erhöhen *)π END;π INC(i); (* i um 1 erhöhen *)π END;π wert := hilfe1.zahl[hilfe1.stellen];π (* letzte Zahl gesondert behandeln *)π WHILE (wert > 0) DO (* solange noch ein Bit gesetzt *)π BEGINπ IF (wert AND 1) > 0 THEN (* Falls 1. Bit gesetzt ist *)π BEGINπ AddCalcStr(ergebnis, hilfe2, hilfe);π (* Hilfe2 zum Ergebnis addieren *)π ergebnis := hilfe; (* und dem Ergebnis zuweisen *)π END;π wert := wert SHR 1; (* Wert durch 2 dividieren *)π Mul2CalcStr(hilfe2); (* Hilfe2 mit 2 multiplizieren *)π END;π END;π hilfe1 := ergebnis; (* Hilfe1 wird Ergebnis zugewiesen *)π ModCalcStr(hilfe1, modul, ergebnis); (* Divisionsrest hilfe1/Modul *)πEND;ππ(* ----------------------------------------------------------------------- *)π(* ExptModCalcStr berechnet basis^exponent MOD modul *)ππPROCEDURE ExptModCalcStr(VAR basis, exponent, modul : CalcStr; VAR ergebnis :πCalcStr);πVAR i, j : WORD; (* Zählvariablen *)π wert : WORD; (* Wert von Zahl an i.ter Stelle *)π hilfe : CalcStr; (* HilfsCalcString *)π hilfe1 : CalcStr; (* HilfsCalcString *)πBEGINπ ergebnis := EMPTYCALCSTR; (* Ergebnis initialisieren *)π ergebnis.stellen := 1; (* Ergebnis besitzt min. 1 Stelle *)π ergebnis.zahl[1] := 1; (* Ergebnis hat mind. Wert 1 *)π IF ((exponent.stellen = 1) AND (exponent.zahl[1] = 0)) OR (exponent.stellen =π0) THENπ (* Exponent = 0 => Ergebnis = 1*)π ELSEπ BEGINπ ModCalcStr(basis, modul, hilfe1); (* Divisionsrest Basis/Modul *)π i := 1; (* i mit 1 initialisieren *)π WHILE (i <= (exponent.stellen - 1)) DOπ BEGINπ wert := exponent.zahl[i]; (* Wert = i.te Stelle von Exponent *)π j := 1; (* j mit 1 initialisieren *)π WHILE (j <= 16) DO (* alle Bits abarbeiten *)π BEGINπ IF (wert AND 1) > 0 THEN (* Falls Bit 1 gesetzt ist *)π BEGINπ MulModCalcStr(ergebnis, hilfe1, modul, hilfe);π (* Ergebnis * Hilfe1 MOD Modul *)π ergebnis := hilfe; (* und dem Ergebnis zuweisen *)π END;π wert := wert SHR 1; (* Wert durch 2 dividieren *)π MulModCalcStr(hilfe1, hilfe1, modul, hilfe);π (* Hilfe1*Hilfe1 MOD Modul *)π hilfe1 := hilfe; (* und wieder Hilfe1 zuweisen *)π INC(j); (* j um 1 erhöhen *)π END;π INC(i); (* 1 um 1 erhöhen *)π END;π wert := exponent.zahl[exponent.stellen];π (* letzte Zahl gesondert behandeln *)π WHILE (wert > 0) DO (* solange noch ein Bit gesetzt *)π BEGINπ IF (wert AND 1) > 0 THEN (* Falls 1. Bit gesetzt ist *)π BEGINπ MulModCalcStr(ergebnis, hilfe1, modul, hilfe);π (* Hilfe1*Ergebnis MOD Modul *)π ergebnis := hilfe; (* und dem Ergebnis zuweisen *)π END;π wert := wert SHR 1; (* Wert durch 2 dividieren *)π MulModCalcStr(hilfe1, hilfe1, modul, hilfe);π (* Hilfe1*Hilfe1 MOD Modul *)π hilfe1 := hilfe; (* und wieder hilfe1 zuweisen *)π END;π END;πEND;ππ(* ----------------------------------------------------------------------- *)ππBEGINππ Randomize; (* Zufallsgenerator einschalten *)ππ (* Initialiseren eines globalen Leerstrings *)π WITH EMPTYCALCSTR DO (* Recordtyp abarbeiten *)π BEGINπ stellen := 0; (* Länge ist 0 *)π FOR i := 1 TO MAXCALCSTR DO zahl[i] := 0; (* zahl initialisieren *)π END;π (* Ende der Initialisierung *)ππEND.π 9 08-25-9409:11ALL RUSS COX Sierpinski's Gasket... SWAG9408 up╙u 24 ₧ {π Sierpinski's Gasket using Pascal's Triangle.π Written by Russ Cox. June 10, 1994.ππ Sierpinski's Gasket starts with an equilateral triangle. /\π / X \π /-------\ππ This triangle then copies itself and puts a copy to the right andπ at the tip.ππ /\π / X \π /\------/\π / X \ /X \π /-------\/-------\ππ It keeps repeating this forever and you get this cool shape, just a lotπ bigger. This was one of the first fractals.ππ Blaise Pascal invented what is known as Pascal's Triangle.ππ 1π 1 1π 1 2 1π 1 3 3 1π 1 4 6 4 1π etc.π You start with sides of 1. As you go down the triangle, to obtain aπ value, you add the numbers above to the left and above to the right.ππ It just so happens that if you color the pixel for Pascal's Triangleπ as to whether or not the number is odd or even, you get Sierpinski'sπ Gasket on your screen. Have fun!!!ππ (Feel free to include this in SWAG if you feel like it. I would put itπ in MATH. )ππ ■ Done! - Kerry ■πππ P.S. If you mess with the right value and leave mid alone... (i.e. makeπ right 480 or something, the part that would have been cut off isπ instead folded over on top of the triangle.ππ}ππprogram gasket;πuses graph;πvarπ grDriver : Integer;π grMode : Integer;π ErrCode : Integer;πconstπ right = 640;π mid = 320;π bottom = 256;ππvarπ oddeven : array[1..right] of Boolean;π c, d, e : integer;π prevoe : array[1..right] of Boolean;ππbeginπgrDriver := Detect;π InitGraph(grDriver,grMode,'e:\bp\bgi');π ErrCode := GraphResult;π if ErrCode <> grOk thenπ beginπ WriteLn('Graphics error:',π GraphErrorMsg(ErrCode));π halt(1);π end;ππ for c := 1 to right doπ prevoe[ c ] := FALSE;ππ prevoe[ mid ] := TRUE;ππ putpixel( mid, 1 , WHITE );π for c := 2 to bottom doπ beginπ for d := 1 to right doπ beginπ if d = 1 thenπ oddeven[ d ] := prevoe[ d + 1 ]π else if d = right thenπoddeven[ d ] := prevoe[ d - 1 ]π elseπ oddeven[ d ] := prevoe[ d - 1 ] xor prevoe[ d + 1 ];ππ if ( d < 640 ) AND ( c < 480 ) thenπ if oddeven[ d ] = TRUE thenπ putpixel( d, c, WHITE )π elseπ putpixel( d, c, BLACK );ππ end;π move( oddeven, prevoe, right );π end;πππend.ππ{πIf you use as a value any power of 2 in the previous program, you get aπfull triangle, without bits and pieces falling off.π} 10 08-25-9409:12ALL JAMIE MORTIMER Virtual Coords SWAG9408 ∩`dM 19 ₧ {πYou can do a basic horizontal starfeild where all you need is an array ofπx,y locations, a routine to draw the stars in the next position, a routineπto remove the old stars, and a routine to update the position array. Or oneπroutine to do all that. That gets boring once you write one. So you want oneπyou can fly into. Now you need x,y and a z coord. To get the virtual x,yπscreen coords for each point, take their 3d-x coord and divide by the 3d-zπcoord, and do the same for the y. This will give you a real number, andπreals are slow so here's an example of just that math using only integers.π}π X : Integer; {3d x coord -maxint to maxint, left to right}π Y : Integer; {y " " top to bottom}π Z : Integer; {z -1..-1023 where '-' is into screen}π xx : integer; {2d x coord}π yy : integer; {y}ππxx:=vidwidth div 2 + longint(x)*1024 div z;πyy:=vidheight div 2 + longint(y)*1024 div z;π{πThat'll give you just plain depth scaling for one star. For many stars,πjust keep an array like this for each of those:π}π X : array [1..maxstars] of integer;π{πYou'd basically follow this pattern:π}π for t:=1 to maxstars doπ beginπ {if star is visible, clear it}π if getpixel(xx[t],yy[t])=starcolor thenπ putpixel(xx[t],yy[t],backgroundcolor);π {update star position}π whatever math you want. Maybe just:π inc(z[t]);π if z<=0 thenπ beginπ x:=random(2048)-1024;π y:=random(2048)-1024;π z:=-1024;π end;π {translate 3d to 2d}π xx[tt]:= {etc from above}π {draw new points}π if getpixel(xx[t],yy[t])=backgroundcolor thenπ putpixel(xx[t],yy[t],starcolor);π end;π{πof course this won't compile, but I assume you like to code and so I'mπonly giving you a general idea. Then you can put another variable in, aπfor example, which is not an array but just a constant which indicatedπthe "angle" of rotation around the z axis. (spinning) it's easy toπimplement that into the equation without any 3d math stuff.π}πxx[tt]:=longint(x[t])*1024 div z[t] * sintable[a mod 360]π div (sin table precision constant, usually 256);ππyy[tt]:=longint(y[t])*1024 div z[t] * costable[a mod 360]π div 256;π
